将表格数据填到word，然后另存为一个新文件

3190496160

Sub 批量委托书()
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
mb = lj & "\委托书 .docx"
With ActiveSheet
    r = .Cells(Rows.Count, 1).End(xlUp).Row
    ar = .Range("a1:a" & r)
End With
wdApp.Visible = True
For i = 2 To UBound(ar)
    If Len(Trim(ar(i, 1))) > 0 Then
        wj = ar(i, 1)
        FileCopy mb, lj & "\" & wj & ".docx"
        Set wdd = wdApp.Documents.Open(lj & "\" & wj & ".docx")
        With wdApp.Selection
            .HomeKey unit:=6 '光标置于文件首
            If .Find.Execute("数据A") Then '查找到指定字符串
                .Font.Color = wdColorAutomatic '字符为自动颜色
                .Text = ar(i, 1) '替换字符串
            End If
        End With
        wdd.Save
        wdd.Close True
        Set wdd = Nothing
    End If
Next i
wdApp.Quit
Set wdApp = Nothing
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "耗时：" & Format(Timer - t, "0.00") & "秒"
End Sub

3190496160

委托.rar (66.58 KB, 下载次数: 5)

2022-11-26 15:53 上传

点击文件名下载附件

3190496160

只写了委托书的代码，其他的自己依样画葫芦吧，

18297921336

3190496160 发表于 2022-11-26 15:54
只写了委托书的代码，其他的自己依样画葫芦吧，

谢谢  谢谢   谢谢   谢谢