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

欧陈养

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

饮冰e士

没图，又不想下载。感觉邮件合并可以？

LIUZHU

我有点奇怪，这个word的《登记表》也算是一个规范的表格，并没有大量的文字，为什么不做成Excel版本呢，这样用VBA生成也方便得多啊。

3190496160

直接在excel中生成一户一表岂不更简单，生成word文档，似乎是在人为的制造麻烦吧

欧陈养

3190496160 发表于 2024-6-4 10:06
直接在excel中生成一户一表岂不更简单，生成word文档，似乎是在人为的制造麻烦吧

直接在excel中生成一户一表也可以

欧陈养

LIUZHU 发表于 2024-6-4 09:55
我有点奇怪，这个word的《登记表》也算是一个规范的表格，并没有大量的文字，为什么不做成Excel版本呢，这 ...

工作需要也没办法啊

魂断蓝桥

Option Explicit
Sub A()
    Dim appWD, doc As Object, m, j, t, n
    Set appWD = CreateObject("Word.Application")
    Dim I, ARR
    Application.ScreenUpdating = False
    ARR = [A1].CurrentRegion
    m = 4
    For I = 2 To UBound(ARR)
        If ARR(I, 8) <> "" Then
            Set doc = appWD.Documents.Open(ThisWorkbook.Path & "\登记表.docx")
            With doc.TABLES(1)
                .cell(2, 1).Range.Text = "户号：" & ARR(I, 1) '户号
                .cell(2, 7).Range.Text = "家庭总人口数：共" & ARR(I, 8) & "  人"
                t = ARR(I, 8)
            End With
        End If
        With doc.TABLES(1)
            For j = 2 To 7
                .cell(m, j) = ARR(I, j)
            Next
        End With
        n = n + 1
        m = m + 1
        If n = t Then
            doc.SaveAs ThisWorkbook.Path & "\" & ARR(I, 1) & "_登记表.docx"
            doc.Close
            m = 4
            n = 0
        End If
Next
appWD.Quit
Set doc = Nothing
Application.ScreenUpdating = True
End Sub

3190496160

Sub 生成word()
Application.ScreenUpdating = False
Dim ar As Variant
Dim i As Long, r As Long, rs As Long
Dim br()
Dim d As Object
Set d = CreateObject("scripting.dictionary")
Set wdApp = CreateObject("word.application")
wdApp.Visible = True
myPath = ThisWorkbook.Path & "\"
With Sheets("资料")
r = .Cells(Rows.Count, 1).End(xlUp).Row
    If r < 2 Then MsgBox "数据源为空，请先导入数据！": End
    ar = .Range("a1:h" & r)
End With
For i = 2 To UBound(ar)
    If ar(i, 1) <> "" Then
        If Not d.exists(ar(i, 1)) Then Set d(ar(i, 1)) = CreateObject("scripting.dictionary")
        d(ar(i, 1))(i) = ""
    End If
Next i
For Each k In d.keys
    n = 0
    ReDim br(1 To UBound(ar), 1 To UBound(ar, 2) - 1)
    For Each kk In d(k).keys
        n = n + 1
        For j = 2 To UBound(ar, 2)
            br(n, j - 1) = ar(kk, j)
        Next j
    Next kk
    FileCopy myPath & "登记表.docx", myPath & "一户一表\" & k & ".docx"
    Set wdD = wdApp.Documents.Open(myPath & "一户一表\" & k & ".docx")
    With wdD.Tables(1)
         .cell(2, 1).Range.Text = "户号：" & k
         .cell(2, 7).Range.Text = "家庭总人口数：共 " & n & " 人"
         For i = 1 To n
            For j = 1 To 7
               .cell(i + 3, j + 1).Range.Text = br(i, j)
            Next j
        Next i
    End With
    wdD.Save
    wdD.Close True
Next k
wdApp.Quit
Set wdD = Nothing
Set wdApp = Nothing
Application.ScreenUpdating = False
MsgBox "ok!"
End Sub

3190496160

新建文件夹 (2).rar (32.74 KB, 下载次数: 34)

2024-6-4 10:23 上传

点击文件名下载附件

欧陈养

3190496160 发表于 2024-6-4 谢谢

谢谢老师