原代码是一行生成一个WORD，如何修改成所有行生成一个WORD

过客fppt

cai2532 发表于 2024-3-13 23:44
您这个有没有文本代码或文件分享下。

https://club.excelhome.net/forum ... ead&tid=1685338
在这个链接里

考试加油站

Sub 邮件合并生成一个文档()
    Dim wdApp As Word.Application, wdDoc As Word.Document, strFileName$, strPath$
    Dim Arr, i&, j&, f$, fdName$
    strPath = ThisWorkbook.path & "\"
    strFileName = strPath & "模板.docx"
    If Dir(strFileName) = "" Then MsgBox "模板.docx文件不存在，请检查！", vbExclamation: Exit Sub
    If Dir(fdName, vbDirectory) = "" Then MkDir (fdName)
    Application.ScreenUpdating = False
    Arr = Sheet1.Range("A1").CurrentRegion
    On Error Resume Next
    Set wdApp = GetObject(, "Word.Application")
    If Err <> 0 Then
        Set wdApp = New Word.Application
    End If
    With wdApp
        With .documents.Open(ThisWorkbook.path & "\模板.docx")
            .Content.Copy
            .Close False
        End With
        With .documents.add
            For i = 3 To UBound(Arr)
                n = n + 1
                If n = 1 Then
                    wdApp.Selection.Paste
                Else
                    With wdApp.Selection
                        .InsertBreak
                        .Goto what:=wdGoToPage, NAME:=n
                        .Paste
                    End With
                End If
                For j = 1 To UBound(Arr, 2)
                    With .Content.Find
                        .Text = "数据" & Format(j, "00")
                        .Replacement.Text = Arr(i, j)
                        .Execute Replace:=wdReplaceAll
                    End With
                Next j
            Next i
            .SaveAs strPath & "合并生成的文档" & Int(Rnd() * 100 + 1): .Close
        End With
    End With
    wdApp.Quit
    Set wdApp = Nothing: Set wdDoc = Nothing
    Application.ScreenUpdating = True
    MsgBox "已完成并将所有文档合并到一起"
End Sub

cai2532

过客fppt 发表于 2024-3-14 10:53
https://club.excelhome.net/forum.php?mod=viewthread&tid=1685338
在这个链接里

在您的这个链接只有图片，文本或文件没有看到呢~