Macro to highlight 100s of proper nouns

[bertietheblue]

Hi

I received a lot of help on here before from Big0, who came up with a macro (below) to highlight a list of proper nouns and phrases. It works fine but I just need to make a couple of tweaks:

- I can only put a limited number of terms in the find text array - I need many 100s (I've just left 'England' in the below for ease of reading; I can add about 60-70 terms without being unable to add more)
- I need to put some phrases with brackets in them into the array, but it doesn't allow this at present.



Any help adapting slightly would be appreciated.

Thanks
Bertie

Sub ReplaceList()
Dim vFindText As Variant
Dim vReplText As Variant
Dim i As Long
'highlight red words
Options.DefaultHighlightColorIndex = wdRed
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
vFindText = Array("England")
vReplText = "^&"
With Selection.Find
  .Forward = True
  .Wrap = wdFindContinue
  .MatchWholeWord = True
  .MatchWildcards = False
  .MatchSoundsLike = False
  .MatchAllWordForms = False
  .Format = True
  .MatchCase = True
  For i = LBound(vFindText) To UBound(vFindText)
    .Text = vFindText(i)
    .Replacement.Text = vReplText
    .Replacement.Highlight = True
    .Execute Replace:=wdReplaceAll
  Next i
End With
End Sub

[macropod]

Try something based on:

Sub ReplaceList()
Application.ScreenUpdating = False
Dim vFindText As Variant, i As Long
'highlight red words
Options.DefaultHighlightColorIndex = wdRed
vFindText = "England,France"
vFindText = vFindText & ",New Zealand,Zambia"
vFindText = Split(vFindText, ",")
With ActiveDocument.Content.Find
  .ClearFormatting
  .Replacement.ClearFormatting
  .Forward = True
  .Wrap = wdFindContinue
  .MatchWholeWord = True
  .MatchWildcards = False
  .MatchSoundsLike = False
  .MatchAllWordForms = False
  .Format = True
  .MatchCase = True
  .Replacement.Text = "^&"
  .Replacement.Highlight = True
  For i = LBound(vFindText) To UBound(vFindText)
    .Text = vFindText(i)
    .Execute Replace:=wdReplaceAll
  Next i
End With
Application.ScreenUpdating = True
End Sub

PS: When posting code, please use the code tags. They're on the 'Go Advanced' tab.

[bertietheblue]

Thanks, macropod and sorry I didn't know about the code tags, but will add in future.

Could I ask 2 quick questions re the code:

(a) Do I put as many terms as will fit into:

vFindText = "England,France"

And then continue in:

vFindText = vFindText & ",New Zealand,Zambia"

And then if that runs out, copy and paste the above to create a 3rd vFindText line (my current list runs to well over 500 terms so I imagine I need quite a few lines)?

(b) I need spaces in some terms so only whole words are found, eg 'An ' - do I just put a space before the following comma?

[macropod]

RE: a
I'd limit the number of entries on each line to what you can see without scrolling in the VBA editor, perhaps even somewhat less than that. You can simply keep adding more:
vFindText = vFindText & ",Name1,Name2"
lines as needed, before the:
vFindText = Split(vFindText, ",")
line.

RE: b
You don't need the space, as your Find/Replace code already has '.MatchWholeWord = True'. Note that you can already use multi-word expressions, such as 'New Zealand'. The only restriction is that they can't use a comma; otherwise you'll need a different separator character.

[bertietheblue]

Thanks, I'll give that a shot tomorrow on the document I'm working on. I've posted another, though related, thread, but I appreciate that you can only answer a limited number of queries.