#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
|
|||
|
|||
VBA IF Statement Help
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
|
|||
|
|||
VBA IF Statement Help
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
|
|||
|
|||
VBA IF Statement Help
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
|
|||
|
|||
VBA IF Statement Help
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
|
|||
|
|||
VBA IF Statement Help
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
|
|||
|
|||
VBA IF Statement Help
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 |