[求助] 批量生成word文件，并打印所生成的word文件

dnvjfdeuff

需求：1、根据合同编号填入相应数据，
          2、生成word文件时，直接打印该文件

陆离Lowry

邮件合并了解下

djp1018

有这样的例子的，搜一下就清楚了

dnvjfdeuff

陆离Lowry 发表于 2022-11-23 10:24
邮件合并了解下

这个需要缴纳过

3190496160

Sub 批量生成打印word()
Application.ScreenUpdating = False
    Dim i%, ar, myPath$, wdApp, wdD
    Set d = CreateObject("scripting.dictionary")
    myPath = ThisWorkbook.Path & "\"
    Set wdApp = CreateObject("word.application")
    wdApp.Visible = False
    t = Timer
    With Sheets("sheet1")
        r = .Cells(Rows.Count, 1).End(xlUp).Row
        ar = .Range("A1:q" & r)
    End With
    For i = 3 To UBound(ar)
        If Trim(ar(i, 4)) <> "" Then
            d(Trim(ar(i, 4))) = d(Trim(ar(i, 4))) + 1
        End If
    Next i
    For Each k In d.keys
        n = 0
        ReDim br(1 To UBound(ar, 1), 1 To UBound(ar, 2))
        For i = 2 To UBound(ar)
            If Trim(ar(i, 4)) = k Then
                n = n + 1
                For j = 1 To UBound(ar, 2)
                    br(n, j) = ar(i, j)
                Next j
            End If
        Next i
        Set wdD = wdApp.Documents.Open(myPath & "采购合同.docx")
        With wdD.Tables(1)
            For i = 1 To n
                For j = 6 To 11
                    .cell(i + 1, j - 4).Range.Text = br(i, j)
                Next j
                .cell(i + 1, 1).Range.Text = br(i, 1)
            Next i
        End With
        For j = 1 To 17
            wdApp.Selection.HomeKey unit:=6 '光标置于文件首
            If wdApp.Selection.Find.Execute("数据" & Format(j, "000")) Then '查找到指定字符串
                wdApp.Selection.Font.Color = wdColorAutomatic '字符为自动颜色
                wdApp.Selection.Text = br(1, j) '替换字符串
            End If
        Next j
        wdD.PrintOut
        wdD.SaveAs Filename:=myPath & Replace(k, "N0:", "合同号_") & ".docx"
        wdD.Close
    Next k
    wdApp.Quit
    Set wdD = Nothing
    Set wdApp = Nothing
    Set d = Nothing
Application.ScreenUpdating = False
MsgBox "耗时：" & Format(Timer - t, "0.00") & "秒！"
End Sub

3190496160

execl文件写入Word.rar (35.33 KB, 下载次数: 38)

2022-11-23 17:00 上传

点击文件名下载附件

3190496160

仅仅提供一个解决问题的整体思路，很多细节未考虑，仅供楼主参考

dnvjfdeuff

3190496160 发表于 2022-11-23 16:59
Sub 批量生成打印word()
Application.ScreenUpdating = False
    Dim i%, ar, myPath$, wdApp, wdD

谢谢，非常感谢

dnvjfdeuff

3190496160 发表于 2022-11-23 17:00

你好，我使用过，只能生成二个文件，提示错误

3190496160

dnvjfdeuff 发表于 2022-11-24 20:55
你好，我使用过，只能生成二个文件，提示错误

在你上传的附件中，根据合同编号，需要生成6个word文档，刚刚又测试了，我这里是可以正常运行的，也生成了6个word文档了