CODEWITHSUNDEEP
vbams-word
CustomX
CustomX

Reputation: 10113

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

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

Upvotes: 0

Views: 2865

Answers (1)

user1379931
user1379931

Reputation:

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.

Upvotes: 1

Related Questions