Can you help me? I changed HOOFDSTUK in JESAJA, but most of the time it starts with content instead of vers I attached the document
And beneath is the macro

Sub ReformatDocument1()
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, "JESAJA.") > 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.F irst)
.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

Attached Files

JESAJA 43 Australia.docx (307.4 KB, 13 views)