word实现excel中多行数据的邮件合并~江湖救急！

ysx133

      各位大神现有excel数据表“hjxx”，需要使用word当中的邮件合并功能，将excel数据表“hjxx”中每一户的信息（多行数据），按照户制作成word调查表（最多13个成员即13行数据）签字确认，请各位大神赐教！ps：表中所有信息都已做处理不是真实信息

excel数据

word邮件合并后实现的结果

我在网上找到了压缩包中pdf格式的多行数据邮件合并教程，但试编辑域代码时第一列数据正常显示，到第二列时还显示的上一行数据，一直找不出原因

补充内容 (2020-6-17 22:56):
12楼更新了用邮件合并的解决方案

补充内容 (2020-6-17 23:04):
wps执行域代码效率很低 配置低的机器会死机 建议使用word

3190496160

Sub 填充word()
Application.ScreenUpdating = False
Dim i%, d, myPath$, wdApp, wdD
Set wdApp = CreateObject("word.application")
Set d = CreateObject("scripting.dictionary")
myPath = ThisWorkbook.Path & "\"
ar = Sheet1.[a1].CurrentRegion
For i = 2 To UBound(ar)
    If Trim(ar(i, 2)) <> "" Then
        d(Trim(ar(i, 2))) = ""
    End If
Next i
For Each k In d.keys
    n = 0
    ReDim br(1 To UBound(ar), 1 To 16)
    For i = 2 To UBound(ar)
        If Trim(ar(i, 2)) = k Then
            n = n + 1
            br(n, 1) = ar(i, 5)
            br(n, 2) = ar(i, 8)
            br(n, 3) = ar(i, 9)
            br(n, 4) = ar(i, 10)
            br(n, 5) = ar(i, 12)
            br(n, 6) = ar(i, 13)
            br(n, 7) = ar(i, 14)
            br(n, 8) = ar(i, 15)
            If Trim(ar(i, 16)) = "是" Then
                br(n, 9) = ar(i, 17)
                br(n, 10) = ar(i, 18)
            ElseIf Trim(ar(i, 16)) = "否" Then
                br(n, 9) = ""
                br(n, 10) = ""
                br(n, 11) = "否"
            End If
            br(n, 12) = ar(i, 19)
            br(n, 13) = ar(i, 20)
            br(n, 14) = ar(i, 21)
            br(n, 15) = ar(i, 22)
            br(n, 16) = ar(i, 23)
            zz = ar(i, 11)
            hz = ar(i, 5)
        End If
    Next i
    FileCopy myPath & "调查表模板.docx", myPath & "生成的文件\" & hz & "调查表.docx"
    Set wdD = wdApp.Documents.Open(myPath & "生成的文件\" & hz & "调查表.docx")
    wdApp.Visible = False
    With wdD.Tables(1)
        For i = 1 To n
            For j = 1 To UBound(br, 2)
                .Cell(i + 5, j).Range.Text = br(i, j)
            Next j
        Next i
    End With
    wdD.Save
    wdD.Close
Next k
wdApp.Quit
    Set wdD = Nothing
    Set wdApp = Nothing
Application.ScreenUpdating = True
MsgBox "ok!"
   
End Sub

ysx133

各位大神 附件中有一个pdf教程 但我一直编辑不成功

3190496160

vba代码是可以做到的，先留个足印吧

ysx133

3190496160 发表于 2020-6-11 08:56
Sub 填充word()
Application.ScreenUpdating = False
Dim i%, d, myPath$, wdApp, wdD

感谢！

ysx133

授人以鱼，不如授人以渔。vb一直不会弄，有大神按邮件合并的思路作一下的吗，不胜感激！

413191246se

楼主，不要光说感谢，还要说一下 3190496160 老师的代码，运行是否成功，问题是否解决，这是关键。

3190496160

413191246se 发表于 2020-6-12 15:10
楼主，不要光说感谢，还要说一下 3190496160 老师的代码，运行是否成功，问题是否解决，这是关键。

说的很有道理，别人给了你帮助最起码要有一个反馈

shenjianrong163

ysx133 发表于 2020-6-12 14:45
授人以鱼，不如授人以渔。vb一直不会弄，有大神按邮件合并的思路作一下的吗，不胜感激！

蓝版主的一个贴子“用ExcelVBA做的类似邮件合并功能”，楼主可以参考下：
http://club.excelhome.net/thread-1513849-1-1.html

ysx133

413191246se 发表于 2020-6-12 15:10
楼主，不要光说感谢，还要说一下 3190496160 老师的代码，运行是否成功，问题是否解决，这是关键。

vb直接不会，正找朋友测试呢~