I have a VBA code to compile an instruction document by compiling a number of separate word documents. These documents contain a heading along with a chapter number. I have regular chapters, but also appendices. The code creates the final compiled document by using a word template. This template already contains a table of contents. However, when all the chapters are inserted, the appendix header numbering does not continue. I.e. all appendices have number "I" as chapter number. I would like the code to recognize all the appendices and update them all using roman numbers (.e.g I, II, III etc.). I can't seem to find a solution for this. I've tried using ChatGPT (bad idea) because I don't have much experience with VBA. This code is from my previous colleague.

Public Sub CreateReports()
Dim DwSpecification As String
Dim SpecificationPath As String
Dim InstructionPath As String
Dim Word As Word.Application
Dim LoopCounter
Dim rng As Range
Dim sKillWord As String
Dim par As Paragraph
Dim Doc As Word.Document
Dim Paragraphcounter

Set Word = CreateObject("Word.Application")

InstructionPath = "C:\Temp\"
SpecificationPath = Trim(ActiveDocument.Bookmarks("SpecificationFolder").Range.Text)

If Right(SpecificationPath, 1) <> "\" Then
    SpecificationPath = SpecificationPath & "\"
End If

ActiveDocument.Bookmarks("SpecificationFolder").Range.Text = ""

Open SpecificationPath & "Support Files\InstallationInstructionBreakdown.txt" For Input As #1

Paragraphcounter = 1
LoopCounter = 1

'Goes through all bookmarks in Word
Do Until EOF(1)
    Line Input #1, textline
    Text = Text & textline

If Text = "0" Then
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = "Paragraph" & Paragraphcounter
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
Selection.Find.Execute Replace:=wdReplaceAll
Selection.Delete
Selection.Delete
Paragraphcounter = Paragraphcounter + 1
 End If
 

If Left(Text, 10) = "Bookmark#1" Then
Text = Mid(Text, InStr(Text, "=") + 1, Len(Text) - 10)

ThisDocument.CustomDocumentProperties.Add _
Name:="Doc_Property_Number", LinkToContent:=False, Value:=Text, _
Type:=msoPropertyTypeString

ActiveDocument.Bookmarks("Bookmark1").Range.Text = Text
  Text = "Bookmark"
End If

If Left(Text, 10) = "Bookmark#2" Then
Text = Mid(Text, InStr(Text, "=") + 1, Len(Text) - 10)
 ActiveDocument.Bookmarks("Bookmark2_1").Range.Text = Text
 ActiveDocument.Bookmarks("Bookmark2_2").Range.Text = Text
 ActiveDocument.Bookmarks("Bookmark2_3").Range.Text = Text
   Text = "Bookmark"
End If

If Left(Text, 10) = "Bookmark#3" Then
Text = Mid(Text, InStr(Text, "=") + 1, Len(Text) - 10)
ActiveDocument.Bookmarks("Bookmark3").Range.Text = Text
  Text = "Bookmark"
End If

If Left(Text, 10) = "Bookmark#4" Then
Text = Mid(Text, InStr(Text, "=") + 1, Len(Text) - 10)
ActiveDocument.Bookmarks("Bookmark4").Range.Text = Text
  Text = "Bookmark"
End If

If Left(Text, 10) = "Bookmark#5" Then
Text = Mid(Text, InStr(Text, "=") + 1, Len(Text) - 10)
ActiveDocument.Bookmarks("Bookmark5").Range.Text = Text
  Text = "Bookmark"
End If

If Left(Text, 10) = "Bookmark#6" Then
Text = Mid(Text, InStr(Text, "=") + 1, Len(Text) - 10)
ActiveDocument.Bookmarks("Bookmark6").Range.Text = Text
  Text = "Bookmark"
End If

If Left(Text, 10) = "Bookmark#7" Then
Text = Mid(Text, InStr(Text, "=") + 1, Len(Text) - 10)
ActiveDocument.Bookmarks("Bookmark7").Range.Text = Text
  Text = "Bookmark"
End If

'Goes through all Paragraph bookmarks in Word
If Not Left(Text, 8) Like "Bookmark" And Text <> "0" Then
Documents.Open FileName:=InstructionPath & Text, ReadOnly:=True
    Selection.WholeStory
    Selection.Copy
    ActiveDocument.Close False

 Wait 1
    
    ThisDocument.Activate
    Set rng = ActiveDocument.Bookmarks("Paragraph" & LoopCounter).Range
    rng.Select
    Selection.InsertBreak Type:=wdPageBreak
Wait 1
'    rng.Paste
     rng.PasteAndFormat wdFormatOriginalFormatting
    Selection.Delete
    rng.Font.Hidden = False

Paragraphcounter = Paragraphcounter + 1
End If

LoopCounter = LoopCounter + 1
Text = ""
Loop

'Deletes any remaining bookmarks
Do While Paragraphcounter < 17
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = "Paragraph" & Paragraphcounter
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
Paragraphcounter = Paragraphcounter + 1
Loop

Paragraphcounter = ""
LoopCounter = ""
Close #1

'Deletes any blank pages
Call DeleteBlankPages
With ActiveDocument.Characters.Last
  While .Previous.Text Like "[ " & Chr(160) & vbCr & vbTab & Chr(12) & "]"
    .Previous.Text = vbNullString
  Wend
End With

'Updates table of content
ActiveDocument.TablesOfContents(1).Update
ActiveDocument.Fields.Update

End Sub
Sub Wait(n As Long)
    Dim t As Date
    t = Now
    Do
        DoEvents
    Loop Until Now >= DateAdd("s", n, t)
End Sub
Function DeleteBlankPages()
    Dim par As Paragraph
    On Error Resume Next
    For Each par In wd.Paragraphs
        If Len(par.Range.Text) <= 1 Then
            par.Range.Delete
        End If
    Next par
End Function