你可以试试这个。您需要通过 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
为了合并评论...
我相信评论中描述的 OP 的问题可能是由于将 .xls 文件直接放在 c:\ 下,这可能导致权限问题,和/或没有更改 .Connectionstring 行以反映 .xls 的实际位置文件。但这很难说。