word邮件合并求助

wddst

之前发到了excel板块里，希望有大神帮我解决一下，谢谢！！！

http://club.excelhome.net/thread-1313954-1-1.html

duquancai

你并不着急，明年再来解决。

jiminyanyan

不要重复发帖。。。。

duquancai

附件，打开word文档，点击按钮》》》》》》

1. Sub shishi()
   
2.    Dim dd As New ADO, sql$, pf$, astr$, n%, m%, a, d, k
   
3.    Set d = CreateObject("Scripting.Dictionary")
   
4.    Application.ScreenUpdating = False
   
5.    pf = ThisDocument.Path & "\工作簿1.xlsx"
   
6.    sql = "select 名称 from [" & pf & "].[Sheet3$a1:e]"
   
7.    dd.SqStr pf, sql, astr, n, m
   
8.    a = Split(astr, vbCr)
   
9.    For i = 0 To UBound(a) - 1
   
10.       d(a(i)) = ""
    
11.    Next
    
12.    k = d.keys
    
13.    ActiveDocument.Content.Delete
    
14.    With ActiveDocument.Content
    
15.       For j = 0 To d.Count - 1
    
16.          sql = "select * from [" & pf & "].[Sheet3$a1:e] where 名称='" & k(j) & "'"
    
17.          dd.SqStr pf, sql, astr, n, m
    
18.          .InsertAfter vbCr & vbCr: .Collapse 0
    
19.          .Text = "名称" & vbTab & "项目1" & vbTab & "项目2" & vbTab & "项目3" & vbTab & "项目4" & vbCr
    
20.          .InsertAfter astr: .ConvertToTable 1, n, m: .Tables(1).Style = "网格型"
    
21.          .Collapse 0
    
22.       Next
    
23.    End With
    
24.    Application.ScreenUpdating = True
    
25. End Sub

复制代码