vba-操作word替换指定字符

Sub test()
    '先在VBA的"工具(T)"->"引用(R)"中添加引用：Microsoft Word 14.0 Object Library
    Dim objApp As New Word.Application, Path, FileNamePath, i, j, arr, brr, str1, str2
    With Sheets("Sheet1")
        brr = .Range("B1:P1").Value
        arr = .Range("B2:P" & .Cells(.Rows.Count, 2).End(xlUp).Row).Value
    End With
    Path = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "" '获取桌面路径
    Folder = Dir(Path & "123", vbDirectory)   '判断路径为"Path & "123""的文件夹是否存在
    If Folder = "" Then MkDir (Path & "123") '如果不存在，就新建一个
    For i = 1 To UBound(arr)
        On Error Resume Next
        FileCopy ThisWorkbook.Path & "\室停气方案.docx", Path & "123" & arr(i, 1) & "室停气方案.docx"
        If Err <> 0 Then Err.Clear: MsgBox "Word模板已打开，请先关闭模板！": Exit Sub
        FileNamePath = Path & "123" & arr(i, 1) & "室停气方案.docx"
        With objApp
            .Documents.Open FileNamePath
            .Visible = False
            For j = 1 To UBound(arr, 2) '填写文字数据
                str1 = "{$" & brr(1, j) & "}"
                str2 = arr(i, j)
                With .Selection
                    .HomeKey unit:=wdStory '光标置于文件首
                    With .Find
                        .ClearFormatting
                        .Replacement.ClearFormatting
                        .Text = str1
                        .Font.Color = wdColorAutomatic '字符为自动颜色
                        .Replacement.Text = str2 '替换字符串
                        .Execute Replace:=wdReplaceAll
                    End With
                End With
            Next j
        End With
        objApp.Documents.Save
        objApp.Quit
        Set objApp = Nothing
    Next i
    MsgBox "已成功输出到Word文件！", 64, "温馨提示"
End Sub

 

'读取数据
Arr = Range("A2:AK" & lastRowNum)
'将数组塞进sheet
SWAPCFSht.Range("A2").Resize(UBound(Arr), UBound(Arr, 2)).Value = Arr

 

 

 

 

Private Sub CommandButton生成Word文件_Click()
Dim Word对象 As New Word.Application
Dim 模板路径, 模板文件名, 导出路径, 导出文件名, 数据表名, 数据表数据起始行号, 数据表数据终止行号
Dim i, 判断, jStr1, Str2

模板路径 = Range("B2") & "\"
If Range("B2") = "当前" Then
模板路径 = ThisWorkbook.Path & "\"
End If
模板文件名 = Range("B3")
导出路径 = Range("B4") & "\"
If Range("B4") = "当前" Then
导出路径 = ThisWorkbook.Path & "\"
End If
导出文件名 = Range("B5")
数据表名 = Range("B6")
数据表数据起始行号 = Val(Range("B7"))
数据表数据终止行号 = Val(Range("B8"))

判断 = 0
'FileCopy 模板路径 & 模板文件名, 导出路径 & 导出文件名
With Word对象
.Documents.Open 导出路径 & 导出文件名
.Visible = False
.ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument '设置位置在正文
If 数据表数据终止行号 > 数据表数据起始行号 Then
.Selection.WholeStory '全选
.Selection.Copy '复制
For i = 数据表数据起始行号 To 数据表数据终止行号 - 1 '复制页
.Selection.EndKey Unit:=wdStory '全选
.Selection.InsertBreak Type:=wdPageBreak '分页
.Selection.PasteAndFormat (wdPasteDefault) '粘贴
Next i
End If
For i = 数据表数据起始行号 To 数据表数据终止行号
Str1 = "数据001"
Str2 = Sheets("各乡镇汇总").Range("A" & i)
.Selection.HomeKey Unit:=wdStory '光标置于文件首
If .Selection.Find.Execute(Str1) Then '查找到指定字符串
.Selection.Font.Color = wdColorAutomatic '字符为自动颜色
.Selection.Text = Str2 '替换字符串
End If
Str1 = "数据002"
Str2 = Sheets("各乡镇汇总").Range("E" & i)
.Selection.HomeKey Unit:=wdStory '光标置于文件首
If .Selection.Find.Execute(Str1) Then '查找到指定字符串
.Selection.Font.Color = wdColorAutomatic '字符为自动颜色
.Selection.Text = Str2 '替换字符串
End If
Next i
End With
Word对象.Documents.Save
Word对象.Quit
Set Word对象 = Nothing
If 判断 = 0 Then
i = MsgBox("已生成“" & 导出路径 & 导出文件名 & "”！", 0 + 48 + 256 + 0, "提示：")
End If
End Sub

 

 

 

---导入表格到指定位置

  ThisWorkbook.Worksheets("主页").Range("A1:B8").Select
    Selection.Copy
   With Word对象
      .Documents.Open 导出路径 & 导出文件名
      .Visible = True
      .ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument    '设置位置在正文
      Set docRange = .ActiveDocument.Tables(1).Cell(1, 1).Range '指定复制位置
      docRange.PasteExcelTable LinkedToExcel:=True, WordFormatting:=False, RTF:=True
  end with