word邮件合并

wddst

excel表格内容：

名称	项目1	项目2	项目3	项目4
李四	1	1	1	1
王二	2	2	2	2
李四	3	3	3	3
王二	4	4	4	4
张三	5	5	5	5
李四	6	6	6	6

word文本内容：

ABCD

ABCD

ABCD

ABCD

ABCD

名称	项目1	项目2	项目3	项目4

希望合并完的效果为：

ABCD

ABCD

ABCD

ABCD

ABCD

名称	项目1	项目2	项目3	项目4
张三	5	5	5	5

ABCD

ABCD

ABCD

ABCD

ABCD

名称	项目1	项目2	项目3	项目4
王二	2	2	2	2
王二	4	4	4	4

ABCD

ABCD

ABCD

ABCD

ABCD

名称	项目1	项目2	项目3	项目4
李四	1	1	1	1
李四	3	3	3	3
李四	6	6	6	6

只是举个例子希望有大神可以将方法告诉我，时分感谢！！！

jiminyanyan

1. Sub NewSht()
   
2.     Dim Dic As Object
   
3.     Dim Arr, Ary, k%, i%, icol%
   
4.     Dim WordAPP As Object, myWord As Object
   
5.     Set WordAPP = CreateObject("Word.Application")
   
6.     Set Dic = CreateObject("Scripting.Dictionary")
   
7.     Arr = Range("A1", [A65536].End(3)(1, 5))
   
8.     For k = 2 To UBound(Arr)
   
9.         Dic(Arr(k, 1)) = ""
   
10.     Next
    
11. 
    
12.     For Each Key In Dic.keys
    
13.         If Key <> "" Then
    
14.             ReDim Ary(0 To UBound(Arr), 1 To 5)
    
15.             i = -1
    
16.             For k = 1 To UBound(Arr)
    
17.                 If Arr(k, 1) = Key Or k = 1 Then
    
18.                     i = i + 1
    
19.                     For icol = 1 To 5
    
20.                         Ary(i, icol) = Arr(k, icol)
    
21.                     Next
    
22.                 End If
    
23.             Next
    
24. 
    
25.    
    
26.     Set myWord = WordAPP.documents.Open(ThisWorkbook.Path & "\模板.docx")
    
27.     WordAPP.Visible = True
    
28.     '=============追加表格=============
    
29.     Set myTable = myWord.Tables(1)
    
30.     Dim ii As Integer
    
31.     If i >= 2 Then
    
32.         For ii = 1 To i - 1
    
33.             myTable.Rows.Last.Select
    
34.             WordAPP.Selection.InsertRowsBelow
    
35.         Next
    
36.     End If
    
37.     '===========追加表格================
    
38.     For ii = 1 To i
    
39.         For jj = 1 To 5
    
40.             myTable.Cell(ii + 1, jj).Range = Ary(ii, jj)
    
41.         Next
    
42.     Next
    
43.     myWord.SaveAs ThisWorkbook.Path & "" & Key & ".doc"
    
44.     myWord.Close
    
45.                              
    
46.         End If
    
47.     Next
    
48.     Dic.RemoveAll
    
49.     Set myWord = Nothing
    
50.    Set WordAPP = Nothing
    
51. End Sub
    

复制代码

jiminyanyan

............

wddst

jiminyanyan 发表于 2016-11-27 10:34

大神  我用别的表也能用么 我的内容比这个多

jiminyanyan

wddst 发表于 2016-11-28 09:03
大神  我用别的表也能用么 我的内容比这个多

学一下思路，改写一下应不难。