![]() |
|
#16
|
|||
|
|||
|
Shelley, Your requirement is pretty complex and I've spent about all the free time on it as I have to spare. Take a look at this:
Code:
Sub CompoundCRs()
Dim strTerms As String
Dim arrTerms() As String
Dim lngIndex As Long, lngOffset As Long
Dim bCompound As Boolean
Dim oRng As Range
Application.ScreenUpdating = False
strTerms = "[Aa]rticle,[Aa]ppendix,[Cc]lause,[Pp]aragraph,[Pp]art,[Ss]chedule" 'highlight numbers after these words
arrTerms = Split(strTerms, ",")
On Error GoTo Err_Handler
For lngIndex = 0 To UBound(arrTerms)
Set oRng = ActiveDocument.Range
'Set oRng = oRng.Duplicate
With oRng.Find
.ClearFormatting
.Replacement.ClearFormatting
.Forward = True
.Wrap = wdFindStop
.MatchWildcards = True
.Text = arrTerms(lngIndex) & "[s ^s]@[0-9.]{1,}" 'Highlight manual cross refs
Do While .Execute
oRng.MoveStart wdWord, 1
oRng.HighlightColorIndex = wdBrightGreen
oRng.Collapse wdCollapseEnd
bCompound = True
Do While bCompound
Select Case True
Case oRng.Characters.Last.Text = "-"
oRng.Move wdCharacter, 1
lngOffset = 0
Case oRng.Characters.Last.Text = "," And oRng.Characters.Last.Next.Text = " "
oRng.Move wdCharacter, 2
lngOffset = 0
Case oRng.Characters.Last.Text = " " And oRng.Characters.Last.Next.Text = "-" And oRng.Characters.Last.Next.Next.Text = " "
oRng.Move wdCharacter, 3
lngOffset = 3
Case oRng.Characters.Last.Text = " " And oRng.Characters.Last.Next.Text = "t" And oRng.Characters.Last.Next.Next.Text = "o" And oRng.Characters.Last.Next.Next.Next.Text = " "
oRng.Move wdCharacter, 4
lngOffset = 4
Case oRng.Characters.Last.Text = " " And oRng.Characters.Last.Next.Text = "o" And oRng.Characters.Last.Next.Next.Text = "r" And oRng.Characters.Last.Next.Next.Next.Text = " "
oRng.Move wdCharacter, 4
lngOffset = 4
Case oRng.Characters.Last.Text = " " And oRng.Characters.Last.Next.Text = "a" And oRng.Characters.Last.Next.Next.Text = "n" And oRng.Characters.Last.Next.Next.Next.Text = "d" And oRng.Characters.Last.Next.Next.Next.Text = "d"
oRng.Move wdCharacter, 5
lngOffset = 5
Case 2 = 1 'I'll let you work out hte and/or syntax
Case Else
bCompound = False
End Select
If bCompound Then
oRng.MoveEnd wdCharacter, 1
Do While IsNumeric(oRng.Characters.Last.Next) Or (oRng.Characters.Last.Next = "." And IsNumeric(oRng.Characters.Last.Next.Next))
oRng.MoveEnd wdCharacter, 1
Loop
If IsNumeric(oRng.Characters.First.Text) Then oRng.HighlightColorIndex = wdBrightGreen
oRng.Collapse wdCollapseEnd
If lngOffset > 0 Then
oRng.Move wdCharacter, -lngOffset
End If
End If
Loop
Loop
End With
Next_For:
Next
Application.ScreenUpdating = True
MsgBox "Complete"
Selection.HomeKey Unit:=wdStory
lbl_Exit:
Exit Sub
Err_Handler:
MsgBox Err.Number & " - " & Err.Description
Resume Next_For
End Sub
|
|
#17
|
|||
|
|||
|
Hi Greg, quite simply WOW, this is simply amazing, thank you so much for spending the time on creating this, it would take me a lifetime to come up with something like this, really can't thank you enough.
I can see its those pesky non breaking spaces causing trouble again, I will have to test further with ^s, although strangely it works ok for 'and'. Just so I can understand the code a bit better, the 'and' part of the code below seems to have two "d" ranges and I wondered why that was. Code:
Case oRng.Characters.Last.text = " " And oRng.Characters.Last.Next.text = "a" And oRng.Characters.Last.Next.Next.text = "n" And oRng.Characters.Last.Next.Next.Next.text = "d" And oRng.Characters.Last.Next.Next.Next.text = "d"
oRng.Move wdCharacter, 5 'Seperated by the word 'and'
lngOffset = 5
Code:
Case oRng.Characters.Last.text = " " And oRng.Characters.Last.Next.text = "a" And oRng.Characters.Last.Next.Next.text = "n" And oRng.Characters.Last.Next.Next.Next.text = "d" And oRng.Characters.Last.Next.Next.Next.Next.text = "/" _ And oRng.Characters.Last.Next.Next.Next.Next.Next.text = "o" And oRng.Characters.Last.Next.Next.Next.Next.Next.Next.text = "r" And oRng.Characters.Last.Next.Next.Next.Next.Next.Next.Next.text = " " oRng.Move wdCharacter, 8 lngOffset = 8 |
|
#18
|
|||
|
|||
|
Shelley,
The double "d" was a typo. Rather than repeating the fourth validator, the fifth validator should have been: oRng.Characters.Last.Next.Next.Next.Next.Text = " " Yes, you were very close. So close in fact that I copied your code into the procedure and it worked fine. Now, when you run the revised code in the attached document you are going to get an error message. I will leave it to you to figure out why and how you want to handle it. Also, the next suggestion it to break your main procedure up into meaningful chunks. You have already got a process for highlighting your manual CRs. Rather than burying it is a tangle of other code, break it out into a separate procedure. This can make troubleshooting and managing your project easier. E.g., Code:
Sub MainProcedure()
Application.ScreenUpdating = False
'Do things
'Do things
'Call the CompoundCR procedure for the main text then footnotes
CompoundCRs ActiveDocument.Range
CompoundCRs ActiveDocument.StoryRanges(wdFootnotesStory)
'Do things or call other procedures
Application.ScreenUpdating = True
Selection.HomeKey Unit:=wdStory
MsgBox "Complete"
lbl_Exit:
Exit Sub
End Sub
Sub CompoundCRs(oRngPassed As Range)
Dim strTerms As String
Dim arrTerms() As String
Dim lngIndex As Long, lngOffset As Long
Dim bCompound As Boolean
Dim oRng As Range
strTerms = "[Aa]rticle,[Aa]ppendix,[Cc]lause,[Pp]aragraph,[Pp]art,[Ss]chedule" 'highlight numbers after these words
arrTerms = Split(strTerms, ",")
On Error GoTo Err_Handler
Set oRng = oRngPassed.Duplicate
'The reason the one instance with the non-breaking space was missed is because you had a non-breaking and normal space (2 spaces)
With oRng.Find
.ClearFormatting
.Replacement.ClearFormatting
.Forward = True
.Wrap = wdFindStop
.MatchWildcards = True
.Text = "[ ^s]{2,}"
.Replacement.Text = " "
.Execute Replace:=wdReplaceAll
End With
For lngIndex = 0 To UBound(arrTerms)
Set oRng = oRngPassed.Duplicate
With oRng.Find
.ClearFormatting
.Replacement.ClearFormatting
.Forward = True
.Wrap = wdFindStop
.MatchWildcards = True
.Text = arrTerms(lngIndex) & "[s ^s]@[0-9.]{1,}"
Do While .Execute
oRng.Select
oRng.MoveStart wdWord, 1
oRng.HighlightColorIndex = wdBrightGreen
oRng.Collapse wdCollapseEnd
bCompound = True
Do While bCompound
Select Case True
Case oRng.Characters.Last.Text = "-"
oRng.Move wdCharacter, 1
lngOffset = 0
Case oRng.Characters.Last.Text = "," And oRng.Characters.Last.Next.Text = " "
oRng.Move wdCharacter, 2
lngOffset = 0
Case oRng.Characters.Last.Text = " " And oRng.Characters.Last.Next.Text = "-" And oRng.Characters.Last.Next.Next.Text = " "
oRng.Move wdCharacter, 3
lngOffset = 3
Case oRng.Characters.Last.Text = " " And oRng.Characters.Last.Next.Text = "t" And oRng.Characters.Last.Next.Next.Text = "o" And oRng.Characters.Last.Next.Next.Next.Text = " "
oRng.Move wdCharacter, 4
lngOffset = 4
Case oRng.Characters.Last.Text = " " And oRng.Characters.Last.Next.Text = "o" And oRng.Characters.Last.Next.Next.Text = "r" And oRng.Characters.Last.Next.Next.Next.Text = " "
oRng.Move wdCharacter, 4
lngOffset = 4
Case oRng.Characters.Last.Text = " " And oRng.Characters.Last.Next.Text = "a" And oRng.Characters.Last.Next.Next.Text = "n" And oRng.Characters.Last.Next.Next.Next.Text = "d" And oRng.Characters.Last.Next.Next.Next.Next.Text = " "
oRng.Move wdCharacter, 5
lngOffset = 5
Case oRng.Characters.Last.Text = " " And oRng.Characters.Last.Next.Text = "a" And oRng.Characters.Last.Next.Next.Text = "n" And oRng.Characters.Last.Next.Next.Next.Text = "d" And oRng.Characters.Last.Next.Next.Next.Next.Text = "/" _
And oRng.Characters.Last.Next.Next.Next.Next.Next.Text = "o" And oRng.Characters.Last.Next.Next.Next.Next.Next.Next.Text = "r" And oRng.Characters.Last.Next.Next.Next.Next.Next.Next.Next.Text = " "
oRng.Move wdCharacter, 8
lngOffset = 8
Case Else
bCompound = False
End Select
If bCompound Then
oRng.MoveEnd wdCharacter, 1
Do While IsNumeric(oRng.Characters.Last.Next) Or (oRng.Characters.Last.Next = "." And IsNumeric(oRng.Characters.Last.Next.Next))
oRng.MoveEnd wdCharacter, 1
Loop
If IsNumeric(oRng.Characters.First.Text) Then oRng.HighlightColorIndex = wdBrightGreen
oRng.Collapse wdCollapseEnd
If lngOffset > 0 Then
oRng.Move wdCharacter, -lngOffset
End If
End If
Loop
Loop
End With
Next_For:
Next
lbl_Exit:
Exit Sub
Err_Handler:
MsgBox Err.Number & " - " & Err.Description
Resume Next_For
End Sub
|
|
#19
|
|||
|
|||
|
Shelly,
After some more thought, I think setting a range from the end of a found CR number to the end of the storyrange and then using InStr is easier to code and perhaps more efficient (also no errors): Code:
Sub Test()
Application.ScreenUpdating = False
CompoundCRs2 ActiveDocument.Range
CompoundCRs2 ActiveDocument.StoryRanges(wdFootnotesStory)
Application.ScreenUpdating = True
Selection.HomeKey Unit:=wdStory
MsgBox "Complete"
End Sub
Sub CompoundCRs2(oRngPassed As Range)
Dim strTerms As String
Dim arrTerms() As String
Dim lngIndex As Long, lngOffset As Long
Dim bCompound As Boolean
Dim oRng As Range, oRngEval As Range
strTerms = "[Aa]rticle,[Aa]ppendix,[Cc]lause,[Pp]aragraph,[Pp]art,[Ss]chedule" 'highlight numbers after these words
arrTerms = Split(strTerms, ",")
On Error GoTo Err_Handler
Set oRng = oRngPassed.Duplicate
'The reason the one instance with the non-breaking space was missed is because you had a non-breaking and normal space (2 spaces)
With oRng.Find
.ClearFormatting
.Replacement.ClearFormatting
.Forward = True
.Wrap = wdFindStop
.MatchWildcards = True
.Text = "[ ^s]{2,}"
.Replacement.Text = " "
.Execute Replace:=wdReplaceAll
End With
For lngIndex = 0 To UBound(arrTerms)
Set oRng = oRngPassed.Duplicate
With oRng.Find
.ClearFormatting
.Replacement.ClearFormatting
.Forward = True
.Wrap = wdFindStop
.MatchWildcards = True
.Text = arrTerms(lngIndex) & "[s ^s]@[0-9.]{1,}"
Do While .Execute
oRng.MoveStart wdWord, 1
oRng.HighlightColorIndex = wdBrightGreen
oRng.Collapse wdCollapseEnd
bCompound = True
Do While bCompound
Set oRngEval = oRngPassed.Duplicate
oRngEval.Start = oRng.End
Select Case True
Case InStr(oRngEval, "-") = 1
oRng.Move wdCharacter, 1
lngOffset = 0
Case InStr(oRngEval, ", ") = 1
oRng.Move wdCharacter, 2
lngOffset = 0
Case InStr(oRngEval, " - ") = 1
oRng.Move wdCharacter, 3
lngOffset = 3
Case InStr(oRngEval, " or ") = 1
oRng.Move wdCharacter, 4
lngOffset = 4
Case InStr(oRngEval, " to ") = 1
oRng.Move wdCharacter, 4
lngOffset = 4
Case InStr(oRngEval, " and ") = 1
oRng.Move wdCharacter, 5
lngOffset = 5
Case InStr(oRngEval, " and/or ") = 1
oRng.Move wdCharacter, 8
lngOffset = 8
Case Else
bCompound = False
End Select
If bCompound Then
oRng.MoveEnd wdCharacter, 1
Do While IsNumeric(oRng.Characters.Last.Next) Or (oRng.Characters.Last.Next = "." And IsNumeric(oRng.Characters.Last.Next.Next))
oRng.MoveEnd wdCharacter, 1
Loop
If IsNumeric(oRng.Characters.First.Text) Then oRng.HighlightColorIndex = wdBrightGreen
oRng.Collapse wdCollapseEnd
If lngOffset > 0 Then
oRng.Move wdCharacter, -lngOffset
End If
End If
Loop
Loop
End With
Next_For:
Next
lbl_Exit:
Exit Sub
Err_Handler:
MsgBox Err.Number & " - " & Err.Description
Resume Next_For
End Sub
Last edited by gmaxey; 03-19-2024 at 11:21 PM. |
|
#20
|
|||
|
|||
|
Greg, wow, this code is something else, thank you so much.
Aaaah yes, I am getting an error 5941 member does not exist on this line of code, so I will look into why this is happening: Code:
CompoundCRs2 ActiveDocument.StoryRanges(wdFootnotesStory) That is a very good idea to break the code up into sections as the original highlight code was getting a bit out of control and very hard to see where I was going wrong so I will definitely split that up into smaller chunks. A massive thank you Greg for helping me. |
|
#21
|
|||
|
|||
|
Shelly,
With the revised code, you should not be getting an error with the sample text you provided. Code:
Option Explicit
Sub MainProcedure()
Application.ScreenUpdating = False
'Do things
'Do things
'Call the CompoundCR procedure for the main text then footnotes
CompoundCRs ActiveDocument.Range
CompoundCRs ActiveDocument.StoryRanges(wdFootnotesStory)
'Do things or call other procedures
Application.ScreenUpdating = True
Selection.HomeKey Unit:=wdStory
MsgBox "Complete"
lbl_Exit:
Exit Sub
End Sub
Sub CompoundCRs(oRngPassed As Range)
Dim strTerms As String
Dim arrTerms() As String
Dim lngIndex As Long, lngOffset As Long
Dim bCompound As Boolean
Dim oRng As Range, oRngEval As Range
strTerms = "[Aa]rticle,[Aa]ppendix,[Cc]lause,[Pp]aragraph,[Pp]art,[Ss]chedule" 'highlight numbers after these words
arrTerms = Split(strTerms, ",")
On Error GoTo Err_Handler
Set oRng = oRngPassed.Duplicate
'The reason the one instance with the non-breaking space was missed is because you had a non-breaking and normal space (2 spaces)
With oRng.Find
.ClearFormatting
.Replacement.ClearFormatting
.Forward = True
.Wrap = wdFindStop
.MatchWildcards = True
.Text = "[ ^s]{2,}"
.Replacement.Text = " "
.Execute Replace:=wdReplaceAll
End With
For lngIndex = 0 To UBound(arrTerms)
Set oRng = oRngPassed.Duplicate
With oRng.Find
.ClearFormatting
.Replacement.ClearFormatting
.Forward = True
.Wrap = wdFindStop
.MatchWildcards = True
.Text = arrTerms(lngIndex) & "[s ^s]@[0-9.]{1,}"
Do While .Execute
oRng.MoveStart wdWord, 1
oRng.HighlightColorIndex = wdBrightGreen
oRng.Collapse wdCollapseEnd
bCompound = True
Do While bCompound
Set oRngEval = oRngPassed.Duplicate
oRngEval.Start = oRng.End
Select Case True
Case InStr(oRngEval, "-") = 1
oRng.Move wdCharacter, 1
lngOffset = 0
Case InStr(oRngEval, ", ") = 1
oRng.Move wdCharacter, 2
lngOffset = 0
Case InStr(oRngEval, " - ") = 1
oRng.Move wdCharacter, 3
lngOffset = 3
Case InStr(oRngEval, " or ") = 1
oRng.Move wdCharacter, 4
lngOffset = 4
Case InStr(oRngEval, " to ") = 1
oRng.Move wdCharacter, 4
lngOffset = 4
Case InStr(oRngEval, " and ") = 1
oRng.Move wdCharacter, 5
lngOffset = 5
Case InStr(oRngEval, " and/or ") = 1
oRng.Move wdCharacter, 8
lngOffset = 8
Case Else
bCompound = False
End Select
If bCompound Then
oRng.MoveEnd wdCharacter, 1
Do While IsNumeric(oRng.Characters.Last.Next) Or (oRng.Characters.Last.Next = "." And IsNumeric(oRng.Characters.Last.Next.Next))
oRng.MoveEnd wdCharacter, 1
Loop
If IsNumeric(oRng.Characters.First.Text) Then oRng.HighlightColorIndex = wdBrightGreen
oRng.Collapse wdCollapseEnd
If lngOffset > 0 Then
oRng.Move wdCharacter, -lngOffset
End If
End If
Loop
Loop
End With
Next_For:
Next
lbl_Exit:
Exit Sub
Err_Handler:
MsgBox Err.Number & " - " & Err.Description
Resume Next_For
End Sub
|
|
#22
|
|||
|
|||
|
Hi Greg, I've tested the code and yes it works if there are footnotes present in the document but doesn't work if there are no footnotes, its looking for a footnote but if not there its creating the error. Would something like this work do you think?
Code:
For Each oRng In ActiveDocument.StoryRanges With oRng Select Case .StoryType Case wdMainTextStory, wdFootnotesStory |
|
#23
|
|||
|
|||
|
Shelley,
Ah, yes. I see what you mean. Yes, changing the main procedure to something like this will work: Code:
Sub MainProcedure()
Dim oRng As Range
Application.ScreenUpdating = False
'Do things
'Do things
'Call the CompoundCR procedure for the main text and footnotes (if exists)
For Each oRng In ActiveDocument.StoryRanges
Select Case oRng.StoryType
Case 1, 2: CompoundCRs oRng
End Select
Next oRng
'Do things or call other procedures
Application.ScreenUpdating = True
Selection.HomeKey Unit:=wdStory
MsgBox "Complete"
lbl_Exit:
Exit Sub
End Sub
|
|
#24
|
|||
|
|||
|
Hi Greg, yes that has definitely worked, thank you so much. Thank you for suggesting I split the previous code into a few sections so I can identify any errors easily. I've run each section individually to see how they perform before updating the MainProcedure code with the various Calls and for some reason, the CompoundCRs code is changing spaces after periods at the end of sentences from two spaces to one space (our housestyle is two spaces). I can't see why this is happening though.
I've been trying to update the CompoundCRs code to include if there is a space or non-breaking space present but nothing has worked yet so I remembered what you said in an earlier post that sometimes its best to remove something and put it back in at the end, so I've added a find and replace in the CompoundCRs Code to remove any non-breaking spaces associated with the cross references and created a new Call to reinstate the non-breaking spaces at the end of the process. I can't thank you enough for your help on this, it will really help me a lot when housestyling documents going forward. Code:
Sub DPU_ReinstateNonBreakingSpaces_CRs()
Dim oRng As Range, fld As Field, sFind1 As String, arr() As String, i As Long
sFind1 = "[Aa]rticle [Aa]rticles [Aa]ppendix [Aa]ppendices [Cc]lause [Cc]lauses [Pp]aragraph [Pp]aragraphs [Pp]art [Pp]arts [Ss]chedule [Ss]chedules [Ss]ection [Ss]ections Act [Rr]egulation [Rr]egulations [Oo]rder [Rr]ule [Rr]rules"
Set oRng = ActiveDocument.Range
With oRng.Find
.ClearFormatting
.Replacement.ClearFormatting
.Format = False
.Forward = True
.Wrap = wdFindContinue
.MatchWildcards = True
arr = Split(sFind1, " ")
For i = 0 To UBound(arr)
.text = "(" & arr(i) & ") ([0-9.]{1,})" 'NBS for clause etc. references in the array
.Replacement.text = "\1^s\2"
.Execute Replace:=wdReplaceAll
Next
For Each fld In oRng.Fields 'Spaces before auto cross-refs are NBS
If fld.Type = wdFieldRef Then
If Not fld.Result.Previous Is Nothing Then
Set oRng = fld.Result.Previous.Characters(1)
If oRng.text = Chr(32) Then oRng.text = Chr(160)
End If
End If
Next
End With
End Sub
|
|
#25
|
|||
|
|||
|
Shelley,
The reason for the replacement is code that I added to the CompoundCR procedure to replace 2 or more spaces with a singe space. That fixed that one issue where the CR number wasn't being picked up. You can take that out if you wish. Code:
With oRng.Find
.ClearFormatting
.Replacement.ClearFormatting
.Forward = True
.Wrap = wdFindStop
.MatchWildcards = True
.Text = "[ ^s]{2,}"
.Replacement.Text = " "
.Execute Replace:=wdReplaceAll
End With
|
|
#26
|
|||
|
|||
|
Hello and thank you for your question. To capture cases where more than one bold punctuation occurs together, you can use additional checks inside the IF statement.
|
|
#27
|
|||
|
|||
|
Hi Greg, its been a while since I last responded to you as I've been on annual leave but just wanted to say thank you so much for all the help you have given me for this code, I've come back from annual leave today and started working with the code - it really has come such a long way from where this all started 2 years ago, I really can't thank you enough. Best wishes.
Tessa, thank you for your response also, although not quite sure what you mean by additional checks inside the IF Statement. |
|
#28
|
|||
|
|||
|
Shelley,
You are welcome. You can ignore Tessa. He or she is posting in multiple treads (many already answered and marked solved) with useless drive by responses that add little or nothing to the post. |
|
#29
|
|||
|
|||
|
Thanks Greg, yes I did wonder what the post was about as I think we have covered everything already so it was definitely a pointless post. I will now mark this as solved - it has been an absolute joy to work on my housestyle documents today with this code. Best wishes.
|
|
|
|
Similar Threads
|
||||
| Thread | Thread Starter | Forum | Replies | Last Post |
IF Statement (again)
|
teza2k06 | Excel | 8 | 02-11-2022 08:41 AM |
| Converting a Select statement in Excel to an update statement | shabbaranks | Excel Programming | 5 | 10-31-2018 11:47 PM |
Need a little help with an if statement
|
cangelis | Excel | 2 | 04-08-2015 05:55 PM |
If statement, may be?
|
Tony Singh | Excel | 6 | 03-04-2015 12:52 PM |
Need help with If, Then Statement Please
|
cangelis | Excel | 4 | 01-03-2014 09:10 AM |