excel数据导入word并多个文本内容替换

1261181315a

现在希望通过excel将大量文本内容导入一模板*.doc文件中，现在遇到的问题就是个新生成的文本只有部分被替换了。不清楚具体替换问题出在哪里？请各位给予帮助。

QQ214189912

1. Sub f() '备注在运行代码前应注意勾选工具-引用micorsoft word 1x.0  object library
   
2.     Dim WdApp As Word.Application, Wd As Word.Document, arr, i%, arry, j%
   
3.     arr = Range("A1").CurrentRegion
   
4.     For i = 2 To UBound(arr, 1)
   
5.         Set WdApp = CreateObject("Word.Application")
   
6.         Set Wd = WdApp.Documents.Open(ThisWorkbook.Path & "\设计.doc")
   
7.         WdApp.Visible = False
   
8.         With Wd
   
9.             .Content.Find.ClearFormatting
   
10.             .Content.Find.Replacement.ClearFormatting
    
11.             arry = Array("建设地点：", "工程名称：", "工程性质：", "主要建设内容：")
    
12.             For j = LBound(arry) To UBound(arry)
    
13.                 With .Content.Find
    
14.                     .Text = arry(j)
    
15.                     .Replacement.Text = arry(j) & arr(i, j + 1)
    
16.                     .Forward = True
    
17.                     .Wrap = 1
    
18.                     .Format = False
    
19.                     .MatchCase = False
    
20.                     .MatchWholeWord = False
    
21.                     .MatchByte = True
    
22.                     .MatchWildcards = False
    
23.                     .MatchSoundsLike = False
    
24.                     .MatchAllWordForms = False
    
25.                     If .Execute Then .Execute Replace:=2 Else MsgBox "未找到" & Chr(13) & arry(j)
    
26.                     End With
    
27.                 Next j
    
28.             .SaveAs ThisWorkbook.Path & "\" & arr(i, 1) & ".doc"
    
29.             .Close
    
30.         End With
    
31.         WdApp.Quit
    
32.         Set Wd = Nothing
    
33.         Set WdApp = Nothing
    
34.     Next
    
35.     MsgBox "ok"
    
36. End Sub

复制代码

182197315

Sub 根据模板()
Dim i%, k%, myPath$, arr, wdapp, wdD, wdRng
Set wdapp = CreateObject("Word.Application")
myPath = ThisWorkbook.Path & "\"
arr = Range(Cells(1, 1), Cells(Rows.Count, 4).End(xlUp))
For i = 2 To UBound(arr)
    FileCopy myPath & "设计.doc", myPath & "生成的文件\" & arr(i, 2) & ".doc"
    Set wdD = wdapp.Documents.Open(myPath & "生成的文件\" & arr(i, 2) & ".doc")
    Set wdRng = Nothing
    With wdD
        For k = 1 To 4
            If wdRng Is Nothing Then
                Set wdRng = .Content
            Else
                Set wdRng = .Range(wdRng.End, .Content.End)
            End If
            If wdRng.Find.Execute("数据" & Format(k, "000")) Then wdRng.Text = arr(i, k)
        Next
        .Save
        .Close
    End With
Next
wdapp.Quit
Set wdapp = Nothing
Set wdD = Nothing
End Sub