excel数据批量填入word模板，生成一户一表

ykcbf1100

参与一下，用Excel作模板

附件供参考。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()      '//2024.6.4
   
2.     Application.ScreenUpdating = False
   
3.     Application.DisplayAlerts = False
   
4.     Dim tm: tm = Timer
   
5.     Dim arr, d
   
6.     Set d = CreateObject("scripting.dictionary")
   
7.     Set fso = CreateObject("Scripting.FileSystemObject")
   
8.     p = ThisWorkbook.Path & ""
   
9.     p1 = p & "拆分后文件"
   
10.     If Not fso.FolderExists(p1) Then fso.CreateFolder p1
    
11.     Set sh = ThisWorkbook.Sheets("资料")
    
12.     c = 1     '//拆分列号
    
13.     With sh
    
14.         r = .Cells(.Rows.Count, c).End(xlUp).Row
    
15.         arr = .Range("a1:h" & r)
    
16.     End With
    
17.     For i = 2 To UBound(arr)
    
18.         s = arr(i, c)
    
19.         If Not d.exists(s) Then Set d(s) = CreateObject("Scripting.Dictionary")
    
20.         d(s)(i) = i
    
21.     Next
    
22.     On Error Resume Next
    
23.     For Each k In d.keys
    
24.         m = 3
    
25.         Sheets("模板").Copy
    
26.         Set wb = ActiveWorkbook
    
27.         With wb.Sheets(1)
    
28.             .Name = k
    
29.             .[a2] = "户号：" & k
    
30.             For Each kk In d(k).keys
    
31.                 m = m + 1
    
32.                 For j = 2 To UBound(arr, 2)
    
33.                     .Cells(m, j) = arr(kk, j)
    
34.                     If .Cells(m, 5) = "户主" Then hz = arr(kk, 2): hs = arr(kk, 8)
    
35.                 Next
    
36.             Next
    
37.             .[h2] = "家庭总人口数：共 " & hs & " 人"
    
38.         End With
    
39.         wb.SaveAs p1 & k & "-" & hz
    
40.         wb.Close
    
41.     Next
    
42.     Set d = Nothing
    
43.     Application.ScreenUpdating = True
    
44.     MsgBox "拆分完毕，共用时： " & Format(Timer - tm, "0.000秒"), , "提示"
    
45. End Sub
    

复制代码

3190496160

欧陈养 发表于 2024-6-4 10:38
备注那里怎么改

zhumin1025

https://club.excelhome.net/forum.php?mod=viewthread&tid=1692108&extra=&mobile=2&_dsign=bee2ca91推荐多适应批量填表

欧陈养

ykcbf1100 发表于 2024-6-4 11:02
参与一下。。。

红色怎么改代码

ykcbf1100

欧陈养 发表于 2024-6-4 16:01
红色怎么改代码

改一下吧。

ykcbf1100

把户数写上去。

1. Sub ykcbf()      '//2024.6.4
   
2.     Application.ScreenUpdating = False
   
3.     Application.DisplayAlerts = False
   
4.     Dim tm: tm = Timer
   
5.     Dim arr, brr, d
   
6.     Set d = CreateObject("scripting.dictionary")
   
7.     Set fso = CreateObject("Scripting.FileSystemObject")
   
8.     p = ThisWorkbook.Path & ""
   
9.     p1 = p & "拆分后文件"
   
10.     If Not fso.FolderExists(p1) Then fso.CreateFolder p1
    
11.     Set sh = ThisWorkbook.Sheets("资料")
    
12.     c = 1     '//拆分列号
    
13.     With sh
    
14.         r = .Cells(.Rows.Count, c).End(xlUp).Row
    
15.         arr = .Range("a1:h" & r)
    
16.     End With
    
17.     For i = 2 To UBound(arr)
    
18.         s = arr(i, c)
    
19.         If Not d.exists(s) Then Set d(s) = CreateObject("Scripting.Dictionary")
    
20.         d(s)(i) = i
    
21.     Next
    
22.     On Error Resume Next
    
23.     For Each k In d.keys
    
24.         m = 3
    
25.         ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2))
    
26.         Sheets("模板").Copy
    
27.         Set wb = ActiveWorkbook
    
28.         With wb.Sheets(1)
    
29.             .Name = k
    
30.             .[a2] = "户号：" & k
    
31.             For Each kk In d(k).keys
    
32.                 m = m + 1
    
33.                 For j = 2 To UBound(arr, 2)
    
34.                     .Cells(m, j) = arr(kk, j)
    
35.                     If .Cells(m, 5) = "户主" Then
    
36.                         hz = arr(kk, 2): hs = arr(kk, 8)
    
37.                         .Cells(m, 9) = arr(kk, 8)
    
38.                     End If
    
39.                 Next
    
40.                
    
41.             Next
    
42.             .[h2] = "家庭总人口数：共 " & hs & " 人"
    
43.         End With
    
44.         wb.SaveAs p1 & k & "-" & hz
    
45.         wb.Close
    
46.     Next
    
47.     Set d = Nothing
    
48.     Application.ScreenUpdating = True
    
49.     MsgBox "拆分完毕，共用时： " & Format(Timer - tm, "0.000秒"), , "提示"
    
50. End Sub
    
51. 
    

复制代码

gwjkkkkk

Option Explicit
Sub test()
    Dim wdApp As Object, strFileName$, strPath$
    Dim ar, i&, j&, k&, p&, m&, n&, strSaveName$
   
    strPath = ThisWorkbook.Path & "\"
    strFileName = strPath & "登记表.docx"
    If Dir(strFileName) = "" Then MsgBox "模板文件不存在，请检查！", vbExclamation: Exit Sub
   
    Application.ScreenUpdating = False
    With [A1].CurrentRegion
        ar = .Resize(.Rows.Count + 1).Value
    End With
   
    On Error Resume Next
    Set wdApp = GetObject(, "Word.Application")
    If Err <> 0 Then
        Set wdApp = CreateObject("Word.Application")
    End If
   
    p = 2
    For i = 2 To UBound(ar) - 1
        If ar(i + 1, 1) <> ar(p, 1) Then
            With wdApp.documents.Open(strFileName)
                strSaveName = strPath & ar(p, 1)
                m = 3: n = i - p + 1
                With .Tables(1)
                    For k = p To i
                        m = m + 1
                        For j = 1 To UBound(ar, 2)
                            .Cell(m, j).Range.Text = ar(k, j)
                        Next j
                    Next k
                End With
                With .Content.Find
                    .ClearFormatting
                    .Execute FindText:="户号：", Forward:=True
                    If .Found = True Then .Parent.Text = "户号：" & ar(p, 1)
                End With
                With .Content.Find
                    .ClearFormatting
                    .Execute FindText:="家庭总人口数：共", Forward:=True
                    If .Found = True Then
                        With wdApp.ActiveDocument.Range(.Parent.End + 2, .Parent.End + 2)
                            .InsertAfter n
                        End With
                    End If
                End With
                .SaveAs strSaveName: .Close
            End With
            p = i + 1
        End If
    Next i
   
    If Err <> 0 Then wdApp.Quit
    Set wdApp = Nothing
    Application.ScreenUpdating = True
    Beep
End Sub

gwjkkkkk

参与一下。。。