将表册数据输出到一户一表。

chxw68

1. Sub test()
   
2.     Dim r%, i%
   
3.     Dim arr, brr
   
4.     Dim d As Object
   
5.     Dim wordapp As Word.Application
   
6.     Dim worddoc As Word.Document
   
7. 
   
8.     Application.ScreenUpdating = False
   
9.     Application.DisplayAlerts = False
   
10.     Set d = CreateObject("scripting.dictionary")
    
11.     With Worksheets("sheet1")
    
12.         r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
13.         arr = .Range("a2:g" & r)
    
14.         For i = 1 To UBound(arr)
    
15.             If Not d.exists(arr(i, 2)) Then
    
16.                 Set d(arr(i, 2)) = CreateObject("scripting.dictionary")
    
17.             End If
    
18.             d(arr(i, 2))(i) = Empty
    
19.         Next
    
20.     End With
    
21. 
    
22. 
    
23.     Set wordapp = New Word.Application
    
24.     wordapp.Visible = True
    
25. 
    
26.     For Each aa In d.keys
    
27.         wordname = ThisWorkbook.Path & "\承包书_" & aa & ".doc"
    
28.         FileCopy ThisWorkbook.Path & "\承包书.doc", wordname
    
29.         Set worddoc = wordapp.Documents.Open(Filename:=wordname)
    
30.         worddoc.Select
    
31.         With worddoc
    
32.             With .Tables(1)
    
33.                 For i = 2 To 4
    
34.                     For j = 2 To 6
    
35.                         .Cell(i, j).Range.Text = Empty
    
36.                     Next
    
37.                 Next
    
38.                
    
39.                 .Select
    
40.                 wordapp.Selection.MoveUp wdLine, 1, wdMove
    
41.                 wordapp.Selection.EndKey wdLine
    
42.                 wordapp.Selection.TypeText aa
    
43.                 m = 1
    
44.                 For Each bb In d(aa).keys
    
45.                    m = m + 1
    
46.                    For j = 3 To 7
    
47.                        .Cell(m, j - 1).Range.Text = arr(bb, j)
    
48.                    Next
    
49.                 Next
    
50.             End With
    
51.             .Close True
    
52.         End With
    
53.     Next
    
54.     wordapp.Quit
    
55.     Set wordapp = Nothing
    
56.     Set worddoc = Nothing
    
57.     Application.ScreenUpdating = True
    
58.     MsgBox "一户一档数据生成完毕！"
    
59.     End
    
60. 
    
61. End Sub
    

复制代码

chxw68

详见附件。

zgyn

chxw68 发表于 2023-3-6 20:26
详见附件。

非常感谢你的解答，但点击表格按钮时，提示如下问题，请问如何解决，谢谢。

chxw68

修改好了。

zgyn

chxw68 发表于 2023-3-7 08:41
修改好了。

大师，还是不行，麻烦再帮调试一下，非常感谢。

chxw68

修改好了。

zgyn

chxw68 发表于 2023-3-7 08:50
修改好了。

还是不行，

chxw68

1、按Alt+F11进入Visual Basic窗口
2、按[工具]-[引用]
3、把窗口中前面显示“丢失"的对勾取掉。

zgyn

chxw68 发表于 2023-3-7 09:14
1、按Alt+F11进入Visual Basic窗口
2、按[工具]-[引用]
3、把窗口中前面显示“丢失"的对勾取掉。

非常您的多次回复，还是不行

chxw68

zgyn 发表于 2023-3-7 09:32
非常您的多次回复，还是不行

那我也没办法了。