Sub ReformatDocument()
Application.ScreenUpdating = False
Dim i As Long, j As Long, k As Long, l As Long, Str As String
Dim RngDoc As Range, RngTmp As Range, RngVrs As Range, RngCmt As Range
Dim bQuot As Boolean, SBar As Boolean, oPara As Paragraph
bQuot = Options.AutoFormatAsYouTypeReplaceQuotes
Options.AutoFormatAsYouTypeReplaceQuotes = False
SBar = Application.DisplayStatusBar
Application.DisplayStatusBar = True
Set RngDoc = ActiveDocument.Range
With ActiveDocument.Range
  With .Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Wrap = wdFindContinue
    .Format = True
    .Font.Italic = True
    .MatchWildcards = True
    .Text = "^13([!0-9]*^13)"
    .Replacement.Text = " ^l\1"
    .Execute Replace:=wdReplaceAll
    .Format = False
    .Text = "[ ]@^13"
    .Replacement.Text = "^p"
    .Execute Replace:=wdReplaceAll
    .Text = "[ ]{2;}"
    .Replacement.Text = " "
    .Execute Replace:=wdReplaceAll
    .Text = "\[[0-9]@\]"
    .Replacement.Text = ""
    .Forward = True
    .Wrap = wdFindStop
    .Format = False
    .MatchWildcards = True
    .Execute
  End With
  Do While .Find.Found
    With .Duplicate
      If .Words.First.Previous.Font.Italic = True Then
        .Paragraphs.First.Range.Font.Italic = True
      End If
    End With
    .Collapse wdCollapseEnd
    .Find.Execute
  Loop
End With
DoEvents
With RngDoc
  Str = .Paragraphs.First.Range.Text
  With .Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Wrap = wdFindContinue
    .Format = False
    .MatchWildcards = False
    .Text = Str
    .Replacement.Text = ""
    .Execute Replace:=wdReplaceAll
  End With
  .InsertBefore "<book>" & vbCr & "<book_content>" & vbCr & Str & vbCr & "</book_content>" & vbCr & "<hoofdstuks>" & vbCr
  For Each oPara In .Paragraphs
    With oPara.Range
      If InStr(.Text, "HOOFDSTUK.") > 0 Then l = l + 1
      If .Words.First.Font.Italic = True Then
        If IsNumeric(.Words.First) Then
          Set RngVrs = oPara.Range
          j = RngVrs.Words.First
          StatusBar = "Sorting Verse & Comments for " & l & ":" & j
          Set RngCmt = Nothing
          Set RngTmp = oPara.Range
          With RngTmp
            .Collapse wdCollapseEnd
            .End = RngDoc.End
          End With
          i = i + 1
          If i Mod 100 = 0 Then DoEvents
          For k = 1 To RngTmp.Paragraphs.Count
          i = i + 1
          If i Mod 100 = 0 Then DoEvents
            With RngTmp.Paragraphs(k).Range
              If .Words.First.Font.ColorIndex = wdRed Then
                If IsNumeric(.Words.First) Then
                  If .Words.First = j Then
                    Set RngCmt = .Paragraphs(1).Range
                    With RngCmt
                      Do While Not IsNumeric(.Paragraphs.Last.Next.Range.Characters.First)
                        .MoveEnd wdParagraph, 1
                        If .End = RngDoc.End Then Exit Do
                        If .Paragraphs.Last.Next.Range.Text = UCase(.Paragraphs.Last.Next.Range.Text) Then Exit Do
                      Loop
                    End With
                  End If
                  Exit For
                End If
              End If
            End With
          Next
          If Not RngCmt Is Nothing Then
            RngVrs.Collapse wdCollapseEnd
            RngVrs.FormattedText = RngCmt.FormattedText
            i = i + 1
            If i Mod 100 = 0 Then DoEvents
            With RngCmt
              If .End = RngDoc.End Then .End = .End - 1
              .Delete
            End With
            RngVrs.InsertAfter "</content>" & vbCr
          End If
          RngVrs.InsertAfter "</vers>" & vbCr
        End If
      End If
    End With
  Next
  DoEvents
  Str = "Adding tags. Please Wait •"
  StatusBar = Str
  With .Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Forward = True
    .Wrap = wdFindContinue
    .Format = False
    .MatchWildcards = True
    .Text = " ^l"
    .Replacement.Text = "^p"
    .Execute Replace:=wdReplaceAll
    .Text = "[^13]{2;}"
    .Replacement.Text = "^p"
    .Execute Replace:=wdReplaceAll
    .Text = "[A-Z. ]@([0-9]@)^13"
    .Replacement.Text = "<hoofdstuk number=""\1"">^p"
    Str = Str & " •"
    StatusBar = Str
    .Execute Replace:=wdReplaceAll
    .Text = "([0-9]@)[!0-9A-Z]@[A-Z]@.^13"
    .Replacement.Text = "<hoofdstuk number=""\1"">^p"
    Str = Str & " •"
    StatusBar = Str
    .Execute Replace:=wdReplaceAll
    .Format = True
    .Font.Italic = True
    .Text = "([0-9]@). (*)^13"
    .Replacement.Text = "<vers number=""\1"">^p<title>\2</title>^p"
    .Execute Replace:=wdReplaceAll
    .Text = "([0-9]@).(*)^13"
    .Replacement.Text = "<vers number=""\1"">^p<title>\2</title>^p"
    Str = Str & " •"
    StatusBar = Str
    .Execute Replace:=wdReplaceAll
    .Format = False
    .Text = "^13([0-9]@)(.*)^13"
    .Replacement.Text = "^p<content>\1\2^p"
    Str = Str & " •"
    StatusBar = Str
    .Execute Replace:=wdReplaceAll
    .Text = "^13\<hoofdstuk number"
    .Replacement.Text = "^p</hoofdstuk>^&"
    .Execute Replace:=wdReplaceAll
    .Text = "(^13\<hoofdstuks\>)^13\</hoofdstuk\>"
    .Replacement.Text = "\1"
    .Execute Replace:=wdReplaceAll
    Str = Str & " •"
    StatusBar = Str
    .Execute Replace:=wdReplaceAll
  End With
  DoEvents
  Str = Str & " •"
  StatusBar = Str
  .Collapse wdCollapseEnd
  With .Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Forward = False
    .Text = "\</vers\>"
    .Replacement.Text = ""
    .Wrap = wdFindStop
    .Format = False
    .MatchWildcards = True
    .Execute
  End With
  .End = ActiveDocument.Range.End
  .Text = "</vers>" & vbCr & "</hoofdstuk>" & vbCr & "</hoofdstuks>" & vbCr & "</book>"
End With
With ActiveDocument
  With .Styles(wdStyleNormal)
    With .ParagraphFormat
      .SpaceBefore = 0
      .SpaceAfter = 0
      .Space1
    End With
    .Font.Name = "Courier New"
  End With
  With .Range
    .Style = wdStyleNormal
    .Font.Reset
    .ParagraphFormat.Reset
  End With
End With
Options.AutoFormatAsYouTypeReplaceQuotes = bQuot
StatusBar = ""
MsgBox "Done!"
Application.ScreenUpdating = True
End Sub