A reformatting macro can only work if the documents are consistent. Your Jozua and Haggai documents are not consistent with your Genesis document. There are some things you would need to change for the existing macro to work with your Jozua document:
1. You would need to delete all the content before -
JOZUA
HOOFDSTUK. 1
I really don't know what you intend to happen with all that content and the macro simply doesn't process it properly.
2. Within the 'HOOFDSTUK. 1' range, there are two references to 'JOZUA 1': one before verse 5 and one before verse 10. You would need to delete both of those.
3. From Chapter 6 onwards, you have JOZUA references using roman numerals (sometimes repeated) instead of a '#de HOOFDSTUK.' reference at the beginning of each chapter. You need to use the '#de HOOFDSTUK.' format throughout, as advised for the Genesis document - the macro cannot process roman numerals or chapter references beginning with the book name. Not only that, but even some of the Roman numerals used for the chapters are wrong. With Chapter 22, for example, you have 'JOZUA XII'! Once you correct the Roman numeral numbering sequence, you could run the following macro to convert them all back to Arabic numbering in the form. Duplicated Roman numbering will also be deleted. That should minimise the amount of other clean-up work you need to do before running the other macro.
Code:
Dim Rm As String
Sub ConvertRomanChaptersToArabic()
Application.ScreenUpdating = False
Dim StrFnd As String, StrConv As String, StrPrev As String
With ActiveDocument.Range
StrFnd = Replace(Trim(.Paragraphs(1).Range.Text), vbCr, "")
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Forward = True
.Format = False
.MatchWholeWord = False
.MatchWildcards = True
.Wrap = wdFindContinue
.Text = "[ ]@^13"
.Replacement.Text = "^p"
.Execute Replace:=wdReplaceAll
.Text = "(" & StrFnd & " [IVXL]@>).^13"
.Replacement.Text = "\1^p"
.Execute Replace:=wdReplaceAll
.Wrap = wdFindStop
.Text = StrFnd & " [IVXL]@>^13"
.Replacement.Text = ""
.Execute
End With
Do While .Find.Found
.End = .End - 1
StrConv = .Text
StrConv = Split(StrConv, " ")(UBound(Split(StrConv, " ")))
If StrConv = StrPrev Then
.Paragraphs(1).Range.Delete
Else
StrPrev = StrConv
.Text = Roman2Arabic(StrConv) & "de HOOFDSTUK."
End If
.Collapse wdCollapseEnd
.Find.Execute
Loop
End With
Application.ScreenUpdating = True
End Sub
Public Function Roman2Arabic(C As String) As Long
Dim TB, Arab As Long, i As Byte, A As Long, Utb As Long
If C = "" Then Roman2Arabic = 0: Exit Function
ReDim TB(0): i = 1: Utb = 1: Arab = 0
Rm = UCase(Replace(C, " ", ""))
While i <= Len(Rm)
ReDim Preserve TB(Utb)
A = NBlettre(i)
TB(Utb) = A * LetterVal(Mid(Rm, i, 1))
i = i + A
Utb = Utb + 1
Wend
ReDim Preserve TB(Utb): i = 1
While i < UBound(TB)
If TB(i) < TB(i + 1) Then
Arab = Arab + TB(i + 1) - TB(i)
i = i + 2
Else
Arab = Arab + TB(i)
i = i + 1
End If
Wend
Roman2Arabic = Arab
End Function
Function NBlettre(Deb As Byte) As Byte
Dim i As Long, L As String
NBlettre = 1: L = Mid(Rm, Deb, 1)
For i = Deb + 1 To Len(Rm)
If Mid(Rm, i, 1) = L Then
NBlettre = NBlettre + 1
Else
Exit Function
End If
Next
End Function
Function LetterVal(L As String) As Long
Dim Roman, Arabic, i As Byte
Roman = Array("I", "V", "X", "L", "C", "D", "M")
Arabic = Array(1, 5, 10, 50, 100, 500, 1000)
For i = 0 To 6
If L = Roman(i) Then
LetterVal = Arabic(i)
Exit Function
End If
Next
End Function