Word VBA - run through doc and use excel sheet for replacement text

Question

I'm trying to create a macro that does the following:

Run through the document and look for strings of the format ##. The items I'm looking for are numbers so they will always be ##014, ##054, etc. If it finds a string containing ##...,it needs to search the excel worksheet CodesNew.xls in My Documents. If it finds a matching string in Column A, it needs to replace the string in the word document with the value in Column B. Now comes the tricky part! The value needs to be entered as a mergefield.

All I have now is search a Word doc and replace it.

Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
   .Text = "##*"
   .Replacement.Text = "KDKKD"
   .Forward = True
   .Format = False
   .MatchCase = False
   .MatchWholeWord = False
   .MatchWildcards = True
   .MatchSoundsLike = False
   .MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll

Yes, so the Workbook is named Test.xls and contains the Worksheet CodeNew. Say ##123 is found, it runs through column A, if it finds a match, it will replace ##123 in the word doc by the value in column B (lets say 'mytext'). In Word go to Insert>QuickParts>Field>Mergefield, that's how it needs to be imported. — CustomX
The worksheet contains two columns, A & B. A contains the data the macro uses to look for a match and B contains the value it needs to be replaced with. — CustomX
No, columns A & B just contain the values and no titles. The text 'mytext' needs to be entered as mergefield code. What do you mean with the SQL, I don't understand that part. — CustomX

Unknown Unknown · Accepted Answer · 2012-08-15T16:31:30

You can try this. You'll need to make a reference to the Microsoft ActiveX Data Objects library via Tools->References in the WOrd VBA Editor, fix any path, document and sheet names to be what you need, and add your own error checking. If you are actually using a .xlsx to store the codes, you will need to change the OLE DB provider name

Sub replaceWithNamesFromExcel()
' Alter this as needed
Const strMatch As String = "##[0-9]{1,}"
Dim bOpened As Boolean
Dim connXL As ADODB.Connection
Dim rsXL As ADODB.Recordset
Dim rng1 As Word.Range
Dim rng2 As Word.Range
Set connXL = New ADODB.Connection
With connXL
  ' Fix the path in here to be the one you need
  .ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=C:\mypath\test.xls;Extended Properties=""Excel 8.0;HDR=No;IMEX=1"";"""
  .Open
End With
Set rsXL = New ADODB.Recordset
Set rsXL.ActiveConnection = connXL
Set rng1 = ActiveDocument.Content
With rng1.Find
  .ClearFormatting
  .Replacement.ClearFormatting
  .Text = strMatch
  .Forward = True
  .Format = False
  .MatchCase = False
  .MatchWholeWord = False
  .MatchWildcards = True
  .MatchSoundsLike = False
  .MatchAllWordForms = False
  While .Execute
    Set rng2 = rng1.Duplicate
    rsXL.Open "SELECT F2 FROM [CodeNew$] WHERE F1 = '" & rng2.Text & "'"
    If Not rsXL.EOF Then
      rng2.Fields.Add Range:=rng2, _
        Type:=WdFieldType.wdFieldEmpty, _
        Text:="MERGEFIELD """ & rsXL.Fields(0).Value & """", _
        preserveformatting:=False
    End If
    rsXL.Close
    Set rng2 = Nothing
  Wend
End With
Set rng1 = Nothing
Set rsXL = Nothing
connXL.Close
Set connXL = Nothing
End Sub

In an attempt to consolidate comments...

I believe the OP's problem with this as described in the comments probably results from putting the .xls file directly under c:\, which could cause permission problems, and/or not changing the .Connectionstring line to reflect the real location of the .xls file. But it is difficult to tell.

Word VBA - run through doc and use excel sheet for replacement text

1 Answers