Word VBA - 通过 doc 运行并使用 excel 表替换文本

Question

我正在尝试创建一个执行以下操作的宏：

遍历文档并查找格式为## 的字符串。我要查找的项目是数字，因此它们将始终为##014、##054 等。如果找到包含##...的字符串，则需要在我的文档中搜索excel 工作表CodesNew.xls。如果它在 A 列中找到匹配的字符串，则需要将 word 文档中的字符串替换为 B 列中的值。现在到了棘手的部分！该值需要作为合并字段输入。

我现在只有搜索 Word 文档并替换它。

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

Answer 1

你可以试试这个。您需要通过 WOrd VBA 编辑器中的工具->引用来引用 Microsoft ActiveX 数据对象库，将任何路径、文档和工作表名称修复为您需要的名称，并添加您自己的错误检查。如果您实际使用 .xlsx 来存储代码，则需要更改 OLE DB 提供程序名称

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

试图整合 cmets...

我相信 OP 在 cmets 中描述的问题可能是由于将 .xls 文件直接放在 c:\ 下，这可能导致权限问题，和/或没有更改 .Connectionstring 行以反映真实位置.xls 文件。但很难说。