macro to automatically change things

macropod · #11 12-01-2014, 08:25 PM

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

Similar Threads
Thread	Thread Starter	Forum	Replies	Last Post
VBA Dropdown change list Entries automatically	QA_Compliance_Advisor	Word VBA	20	09-16-2014 07:29 AM
AutoFill- Auto Change Certain things in document?	DaveWW00	Word	1	08-06-2013 11:33 AM
How to change dates automatically	PaperBuster	Word	5	09-24-2012 09:31 PM
Automatically change the value of one cell so that two other cells become equal	matthew544	Excel	5	09-18-2011 08:56 AM
How can I change the colors of cells automatically based on Job Completion?	Learner7	Excel	0	07-06-2010 10:47 PM