求助，VBA替代邮件合并

胡1986

利用VBA快速替换

胡1986

把excle里数据源1导入WORD里，

蓝桥玄霜

办法1：把模板文件中的1.  2.  3. 。。。改为1#  2#  3# 。。。，避免与文件中其它不需要替换地方的1.  2.等混淆，这样就可以采用查找替换的方法来实现，参考http://club.excelhome.net/thread-1580680-1-1.html；
办法2：把模板文件中的1.  2.  3. 。。。依次改为书签，然后可以采用按书签写入的方法来实现，参考http://club.excelhome.net/thread-1517447-1-1.html

3190496160

Sub 替换word()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim wdApp As Object
Set wdApp = CreateObject("Word.Application")   '新建Word对象
Dim wdd
t = Timer
Dim ar As Variant
lj = ThisWorkbook.Path & "\"
f = Dir(lj & "衡柳线下行K12+418三角坑整治方案-序号.docx")
If f = "" Then MsgBox "找不到衡柳线下行K12+418三角坑整治方案-序号.docx": End
FileCopy lj & f, lj & "衡柳线下行K12+418三角坑整治方案" & Format(Date, "yyyy年m月d日") & ".docx"
ar = ActiveSheet.[a1].CurrentRegion
wdApp.Visible = True
Set wdd = wdApp.Documents.Open(lj & "\衡柳线下行K12+418三角坑整治方案" & Format(Date, "yyyy年m月d日") & ".docx")
For i = 2 To UBound(ar)
    If Len(Trim(ar(i, 2))) > 0 Then
        With wdApp.Selection
            .HomeKey unit:=6 '光标置于文件首
            If .Find.Execute(ar(i, 1) & "@") Then '查找到指定字符串
                .Font.Color = wdColorAutomatic '字符为自动颜色
                .Text = ar(i, 2) '替换字符串
            End If
        End With
    End If
Next i
wdd.Close True
wdApp.Quit
Set wdd = Nothing
Set wdApp = Nothing
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "耗时：" & Format(Timer - t, "0.00") & "秒"
End Sub

3190496160

新建文件夹.rar (175.14 KB, 下载次数: 23)

2024-5-20 14:26 上传

点击文件名下载附件

胡1986

3190496160 发表于 2024-5-20 14:25
Sub 替换word()
Application.ScreenUpdating = False
Application.DisplayAlerts = False

提示类型不匹配？

3190496160

胡1986 发表于 2024-5-20 22:52
提示类型不匹配？

没有测试的代码，是绝对不会给你的，
仅就你上传的附件，在微软office和wps中测试都是OK的，
提示类型不匹配，应该是你的单元格区域的问题，只有一个单元格有数据，就不是数组，肯定就会提示类型不匹配

胡1986

3190496160 发表于 2024-5-21 08:11
没有测试的代码，是绝对不会给你的，
仅就你上传的附件，在微软office和wps中测试都是OK的，
提示类型 ...

我用邮件合并可以

3190496160

胡1986 发表于 2024-5-21 19:58
我用邮件合并可以

那你还来求代码呢？

胡1986

3190496160 发表于 2024-5-21 20:57
那你还来求代码呢？

我想更快捷点