Macro to find multiple strings and insert text (specific to each string) at the end of each occurrence

Question

The scenario:

Word documents that contain a selection of sentences (strings). There might be up to 30 possible strings (which vary from 5 to 20 words in length). The document will contain only a selection of these strings.

Aim:

Macro that searches through the document, finds each occurrence of a particular string and inserts a specific text code (such as " (ACWD2553)") after each occurrence. This is repeated for all the other strings in the set, with each different string having it's own distinct code. Some strings won't be in the document. The strings can be located in document body and table cells. The macro would then be applied to other documents which would have different selections of the strings.

I have tried for many days using selection.find, content.find, target.list, insertafter and so on but only with one case and still ran into numerous problems (e.g. only inserting in one instance, or code repeatedly inserting until Word freezes).

Bonus feature ###

Be able to choose which set of strings which will be searched for (there are potentially up to 60 sets) and their corresponding codes. Each document would only have strings from one set.

An idea I had was for the strings to be listed in a column (in Excel?) and the matching codes in the a second column. The macro would then search the document for each string in the list (stopping at the end of the list since the number of strings varies between sets) finds the matching code in the cell in the next column and then inserts the code for each occurrence of the string in the word doc. When a different set is required, the Excel file could be swapped with the file containing the relevant set of stings, but with the same file name. Or all sets in the one Excel file on different worksheets and tab name entered in Word (userform?) which forces search of relevant set. This file would be located on a network drive.

Not sure if this is bigger then Ben Hur, last bit would be nice, but I can also manually enter the strings in the raw code from a template code.

Edited this post to include my poor attempt at the code. See my comment below. I just realised that I could add code to this pane. Tried a variety of iterations of the one below, none of which worked well and which does not approach what I require. I know there are obvious errors, as I said below I have played around with the code and made it worse in the process by mixing bits and pieces together.

Sub Codes()

Dim range As range
Dim i As Long
Dim TargetList

TargetList = Array("This is sentence 1", "This is string 2 which could be twenty words in length", "This is string three, there could be thirty more strings to search") ' put list of terms to find here

For i = 0 To UBound(TargetList)

Set range = ActiveDocument.range

With range.Find
.Text = TargetList(i)
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False

Do While .Execute(Forward:=True) = True
range.Find.Execute
range.InsertAfter Text:=" (ACWD1234)"

Loop

End With
Next

End Sub

Answer 1

Thanks to the two respondents. I don't have the skillset to progress the second code. I ended up searching for reading data from Excel into a word document and found code that worked perfectly.

Using Excel as data source in Word VBA http://social.msdn.microsoft.com/Forums/office/en-US/ca9a31f4-4ab8-4889-8abb-a00af71d7307/using-excel-as-data-source-in-word-vba Code produced by Doug Robbins.

This worked an absolute treat. Also it means that I can edit the Excel file for the different sets of statements and their matching codes. Now it would be particularly sweet if I could work out a way to create a userform that would open when i run the macro and select the appropriate woprksheet based on the userform dropdown list item selected.

Answer 2

The code below does exactly what you need. I dont know if replacing the whole Contents property of the document object has some weird effect into tabulation/formating and so on.

I'd rather not add any overhead with string/array/collection manipulations. Using find-replace is probably the most obvious route, but I don't like that whole lot of options you need to set (because I understand none of them =P)

You need to add a reference to "Microsoft scripting runtime"

Public Sub changeTokens()
    Dim strContents                     As String
    Dim mapperDic                       As Scripting.Dictionary
    Dim thisTokenKey                    As String
    Dim varKey                          As Variant

    Set mapperDic = getTokenMapper()

    For Each varKey In mapperDic.Keys
        thisTokenKey = CStr(varKey)
        ThisDocument.Content = Replace(ThisDocument.Content, thisTokenKey, mapperDic(thisTokenKey))
    Next varKey
End Sub

Public Function getTokenMapper() As Scripting.Dictionary
    ' This function can fetch data from other sources to buidl up the mapping.
    Dim tempDic                         As Scripting.Dictionary
    Set tempDic = New Scripting.Dictionary


    Call tempDic.Add("Token 1", "Token 1 changed!!")
    Call tempDic.Add("Token 2", "Token 1 changed!!")
    Call tempDic.Add("Token 3", "Token 1 changed!!")

    Set getTokenMapper = tempDic
End Function

You can fetch your data to create the mapper dictionary from a excel worksheet with no problems.

Answer 3

I think that this is a time to use replace rather than find, see implementation below. If the specific code changes depending on the target string you can hanlde this easily with a 2 dimensional array

Sub Codes()

Dim i As Long
Dim TargetList
Dim MyRange As range
TargetList = Array("This is sentence 1", "This is string 2 which could be twenty words in length", "This is string three, there could be thirty more strings to search") ' put list of terms to find here
Dim sStringToAdd As String

sStringToAdd = " (ACWD2553)"

For i = 0 To UBound(TargetList)

Set MyRange = ActiveDocument.Content

MyRange.Find.Execute FindText:=TargetList(i), ReplaceWith:=TargetList(i) & sStringToAdd, _
    Replace:=wdReplaceAll


Next i

End Sub