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

考试加油站

1. Sub 邮件合并()
   
2.     Dim wdApp As Word.Application, wdDoc As Word.Document, strFileName$, strPath$
   
3.     Dim Arr, i&, j&, f$, fdName$
   
4.     strPath = ThisWorkbook.Path & ""
   
5.     strFileName = strPath & "模板.docx"
   
6.     If Dir(strFileName) = "" Then MsgBox "模板.docx文件不存在，请检查！", vbExclamation: Exit Sub
   
7.     fdName = ThisWorkbook.Path & "\生成的表格"
   
8.     If Dir(fdName, vbDirectory) = "" Then MkDir (fdName)
   
9.     Application.ScreenUpdating = False
   
10.     Arr = Sheet1.Range("A1").CurrentRegion
    
11.     On Error Resume Next
    
12.     Set wdApp = GetObject(, "Word.Application")
    
13.     If Err <> 0 Then
    
14.         Set wdApp = New Word.Application
    
15.     End If
    
16.     For i = 3 To UBound(Arr)
    
17.         With wdApp.Documents.Open(ThisWorkbook.Path & "\模板.docx")
    
18.             f = fdName & Arr(i, 1)
    
19.             For j = 1 To UBound(Arr, 2)
    
20.                 With .Content.Find
    
21.                     .Text = "数据" & Format(j, "00")
    
22.                     .Replacement.Text = Arr(i, j)
    
23.                     .Execute Replace:=wdReplaceAll
    
24.                 End With
    
25.             Next j
    
26.             .SaveAs f: wdDoc.Close
    
27.         End With
    
28.     Next i
    
29.     wdApp.Quit
    
30.     Set wdApp = Nothing: Set wdDoc = Nothing
    
31.     Application.ScreenUpdating = True
    
32.     MsgBox "完成"
    
33. End Sub
    
34. 
    

复制代码

gwjkkkkk

在你的基础上简单修改一下。。。

边缘码农

Excel中的内容，写入Word或PPt中，总数困难重重，也许是因为对office各组件的对象结构不了解，遇到此类问题，总需要一点一点的实验。

gwjkkkkk

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
    fdName = ThisWorkbook.Path & "\生成的表格\"
    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")
            .Range.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 .Tables(n).Range.Find
                        .Text = "数据" & Format(j, "00")
                        .Replacement.Text = Arr(i, j)
                        .Execute Replace:=wdReplaceAll
                    End With
                Next j
            Next i
            .SaveAs fdName & "\汇总": .Close
        End With
    End With
    wdApp.Quit
    Set wdApp = Nothing: Set wdDoc = Nothing
    Application.ScreenUpdating = True
    MsgBox "完成"
End Sub

过客fppt

https://club.excelhome.net/forum.php?mod=viewthread&tid=1685338&mobile=2
你的需求和这个很像

Lovertdos

你这是一点也不把帖子看完啊，原作者不是有好几种吗方案

cai2532

过客fppt 发表于 2024-3-13 22:25
https://club.excelhome.net/forum.php?mod=viewthread&tid=1685338&mobile=2
你的需求和这个很像

您这个有没有文本代码或文件分享下。

考试加油站

过客fppt 发表于 2024-3-13 22:25
https://club.excelhome.net/forum.php?mod=viewthread&tid=1685338&mobile=2
你的需求和这个很像

感谢回复。

考试加油站

gwjkkkkk 发表于 2024-3-13 21:08
Sub 邮件合并()
    Dim wdApp As Word.Application, wdDoc As Word.Document, strFileName$, strPath$
  ...

非常感谢您的回复，发现一个问题就是WORD模板中内容仅限于表格，而且是一个表格，有多个表格不能实现，同时发现表格外如有数据，也不能实现

边缘码农

Sub 邮件合并()
    '-----------------------------------------------
    '定义Word相关对象
    Dim wdApp As Word.Application '定义Word程序
    Dim wdDoc As Word.Document '定义Word文档
     '定义变量
    Dim strFileName$, strPath$
    Dim Arr, i&, j&, f$, fdName$
    '-----------------------------------------------
    strPath = ThisWorkbook.Path & "\" '取得当前工作簿的路径
    strFileName = strPath & "模板.docx" '取得模板文件的全路径文件名
    '检查模板文件是否存在
    If Dir(strFileName) = "" Then
        MsgBox "模板.docx文件不存在，请检查！", vbExclamation
        Exit Sub
    End If
    '检查生成文件的路径
    fdName = ThisWorkbook.Path & "\生成的表格\"
    If Dir(fdName, vbDirectory) = "" Then MkDir (fdName) '如果目录不存在，则创建
    Application.ScreenUpdating = False '关闭屏幕刷新
    Arr = Sheet1.Range("A1").CurrentRegion '取得要写入Word文档的内容
    On Error Resume Next '出现错误执行下一语句
     '创建Word程序
    Set wdApp = GetObject(, "Word.Application")
    If Err <> 0 Then
        Set wdApp = New Word.Application
    End If
    '打开模板文档
    Set wdDoc = wdApp.Documents.Open(ThisWorkbook.Path & "\模板.docx")
    With wdDoc
        .Bookmarks("\page").Select
        .Content.Copy
        .Close
    End With
    Set wdDoc = Nothing
    '生成目标文件，在执行期间不能进行复制操作
    Set wdDoc = wdApp.Documents.Add '新建一个新文档
    With wdApp
        For i = 3 To UBound(Arr)
            .Selection.Paste '粘贴已复制的内容
            For j = 1 To UBound(Arr, 2)
                '在粘贴的内容中寻找特定数据并替换
                With wdDoc.Content.Find
                    .Text = "数据" & Format(j, "00") '原数据
                    .Replacement.Text = Arr(i, j) '新数据
                    .Execute Replace:=wdReplaceAll '执行替换
                End With
            Next j
            '如果当前处理的人员不是最后一人，插入一页
            If i < UBound(Arr) Then .Selection.InsertNewPage
        Next i
        .ActiveDocument.SaveAs fdName & "汇总"  '当前Word文档另存为
        .ActiveDocument.Close '关闭
    End With
    '释放创建的对象
    Set wdDoc = Nothing
    Set wdApp = Nothing
    '关闭Word
    wdApp.Quit
    Application.ScreenUpdating = True '开启屏幕刷新
    MsgBox "完成"
End Sub