Sub ReformatDocument()
Application.ScreenUpdating = False
Dim i As Long, j As Long, k As Long, l As Long, x As Long
Dim RngDoc As Range, RngVrs As Range, RngCmt As Range, bQuot As Boolean
bQuot = Options.AutoFormatAsYouTypeReplaceQuotes
Options.AutoFormatAsYouTypeReplaceQuotes = False
With ActiveDocument.Styles(wdStyleNormal)
  With .ParagraphFormat
    .SpaceBefore = 0
    .SpaceAfter = 0
    .Space1
  End With
  .Font.Name = "Courier New"
End With
Set RngDoc = ActiveDocument.Range
With RngDoc
  x = .Paragraphs.Count
  For i = 1 To x
    With .Paragraphs(i).Range
      If .Font.Italic = True Then
        If IsNumeric(.Words.First) Then
          j = .Words.First
          Set RngVrs = .Paragraphs(1).Range
          Set RngCmt = Nothing
          For k = i + 1 To x
            With RngDoc.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.Words.First)
                        .MoveEnd wdParagraph, wdForward
                        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
                End If
              End If
            End With
          Next
          If Not RngCmt Is Nothing Then
            RngVrs.Collapse wdCollapseEnd
            RngVrs.FormattedText = RngCmt.FormattedText
            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
  With .Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Forward = True
    .Wrap = wdFindContinue
    .Format = False
    .MatchWildcards = True
    .Text = "[^13]{2,}"
    .Replacement.Text = "^p"
    .Execute Replace:=wdReplaceAll
    .Text = "([A-Z0-9 ]@)^13[A-Z. ]@([0-9]@)^13"
    .Replacement.Text = "<boek titel=""\1"">^p  <hoofdstuk number=""\2"">^p"
    .Execute Replace:=wdReplaceAll
    .Format = True
    .Font.Italic = True
    .Text = "([0-9]@).(*)^13"
    .Replacement.Text = "    <vers number=""\1"">^p      <title number=""\1"">\2^p</title>^p"
    .Execute Replace:=wdReplaceAll
    .Format = False
    .Text = "([0-9]@)(.*)^13"
    .Replacement.Text = "      <content number=""\1"">\1\2^p"
    .Execute Replace:=wdReplaceAll
  End With
  .Style = wdStyleNormal
  .Font.Reset
  .ParagraphFormat.Reset
End With
Options.AutoFormatAsYouTypeReplaceQuotes = bQuot
Application.ScreenUpdating = True
End Sub