邮件合并-一个单位多条记录如何合并

chxw68

1. Sub test()
   
2.     Dim r%, i%
   
3.     Dim arr, brr
   
4.     Dim flg As Boolean
   
5.     Dim mypath$, myname$
   
6.     Dim xlapp As Excel.Application
   
7.     Dim wb As Excel.Workbook
   
8.     Dim ws As Excel.Worksheet
   
9.     Dim d As Object
   
10.     Set d = CreateObject("scripting.dictionary")
    
11.     On Error Resume Next
    
12.     Set xlapp = GetObject(, "excel.application")
    
13.     If Err Then
    
14.         flg = True
    
15.         Set xlapp = CreateObject("excel.application")
    
16.     End If
    
17.     On Error GoTo 0
    
18.     mypath = ThisDocument.Path & ""
    
19.     myname = "文档.xls"
    
20.     If Dir(mypath & myname) = "" Then
    
21.         MsgBox mypath & myname & "不存在！"
    
22.         Exit Sub
    
23.     End If
    
24.     Set wb = xlapp.Workbooks.Open(FileName:=mypath & myname)
    
25.     xlapp.Visible = True
    
26.     With wb
    
27.         With .Worksheets("文档")
    
28.             r = .Range("b1").End(xlDown).Row
    
29.             arr = .Range("a2:j" & r)
    
30.             For i = 1 To UBound(arr)
    
31.                 If Not d.Exists(arr(i, 2)) Then
    
32.                     Set d(arr(i, 2)) = CreateObject("scripting.dictionary")
    
33.                 End If
    
34.                 d(arr(i, 2))(i) = Empty
    
35.             Next
    
36.         End With
    
37.         .Close False
    
38.     End With
    
39.     With ThisDocument
    
40.         For Each aa In d.keys
    
41.             .Tables(1).Select
    
42.             Selection.MoveUp unit:=wdLine, Count:=1
    
43.             Selection.HomeKey unit:=wdLine
    
44.             Selection.EndKey unit:=wdLine, Extend:=wdExtend
    
45.             Selection.MoveEnd unit:=wdCharacter, Count:=-1
    
46.             Selection.Range.Text = "单位名称：" & aa
    
47.             
    
48.             With .Tables(1)
    
49.                 If .Rows.Count > 1 Then
    
50.                     For i = .Rows.Count To 2 Step -1
    
51.                         .Rows(i).Delete
    
52.                     Next
    
53.                 End If
    
54.                 .Rows(1).Range.Select
    
55.                 Selection.InsertRowsBelow numrows:=d(aa).Count
    
56.                 For i = 1 To .Rows.Count
    
57.                     .Rows(i).Height = CentimetersToPoints(1)
    
58.                 Next
    
59.                 m = 1
    
60.                 For Each bb In d(aa).keys
    
61.                     m = m + 1
    
62.                     For j = 3 To UBound(arr, 2)
    
63.                         .Cell(m, j - 1).Range.Text = arr(bb, j)
    
64.                     Next
    
65.                 Next
    
66.             End With
    
67.             ThisDocument.PrintOut
    
68.         Next
    
69.     End With
    
70. End Sub
    

复制代码

chxw68

用VBA实现的，主要是练习。代码在WORD文件中。