Excel批量生成Word文件

灵犀之声

小白一个，只会一行式的VBA，每一条的行数不一样，就不会了。求教各位大神。

根据对应关系，每一条生成一页Word

一剑惊心

邮件合并就可以解决了

灵犀之声

一剑惊心 发表于 2023-7-4 16:40
邮件合并就可以解决了

邮件合并也是只能一行一页，我这个需要多行一页

shiruiqiang

gwjkkkkk

请参考附件。。。

gwjkkkkk

你这个比较有规则，邮件合并还是最简单的。。。

灵犀之声

gwjkkkkk 发表于 2023-7-4 19:46
请参考附件。。。

老师您好，非常感谢，但是我需要的是一个委托编号一页，而不是一行一页。

灵犀之声

shiruiqiang 发表于 2023-7-4 19:02

感谢大佬知道，我试一下

3190496160

Sub 按模板生成文档()
Application.ScreenUpdating = False
Dim i%, arr, myPath$, wdApp, wdD
Dim oFso
Set oFso = CreateObject("Scripting.FileSystemObject")
Dim d As Object
Set d = CreateObject("scripting.dictionary")
myPath = ThisWorkbook.Path & "\"
Set wdApp = CreateObject("word.application")
wdApp.Visible = True
arr = Sheets("sheet1").Range("A1:h" & Cells(Rows.Count, 1).End(xlUp).Row)
For i = 2 To UBound(arr)
    If Trim(arr(i, 1)) <> "" Then
        zf = Trim(arr(i, 1))
        d(zf) = ""
    End If
Next i
For Each k In d.keys
    n = 0
    ReDim br(1 To UBound(arr), 1 To 8)
    For i = 2 To UBound(arr)
        If Trim(arr(i, 1)) = k Then
            n = n + 1
            For j = 1 To 8
                br(n, j) = arr(i, j)
            Next j
        End If
    Next i
    FileCopy myPath & "模板.docx", myPath & "生成的文件\" & k & ".docx"
    Set wdD = wdApp.Documents.Open(myPath & "生成的文件\" & k & ".docx")
    xh = 7
    For i = 1 To n
        With wdD.Tables(1)
             .cell(2, 6).Range.Text = k
             .cell(3, 2).Range.Text = br(i, 2)
             .cell(4, 6).Range.Text = br(i, 8)
             .cell(5, 6).Range.Text = br(i, 7)
             xh = xh + 1
             .cell(xh, 2).Range.Text = br(i, 3)
             .cell(xh, 3).Range.Text = br(i, 4)
             .cell(xh, 4).Range.Text = br(i, 5)
             .cell(xh, 5).Range.Text = br(i, 6)
             .cell(xh, 2).Range.Text = br(i, 3)
        End With
    Next i
    wdD.Save
    wdD.Close True
Next k
wdApp.Quit
Set wdD = Nothing
Set wdApp = Nothing
Application.ScreenUpdating = False
    MsgBox "ok!"
End Sub

3190496160

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

2023-7-5 09:03 上传

点击文件名下载附件