如何实现Excel的多数据批量导入Word模板

zjwieh

各位大神，求帮助。
1、数据源Excel存在多条记录，需要按【设备类别】导入到Word模板中；

2、数据源Excel中的同一个【设备类别】包含多个子设备；
3、需要将同一个【设备类别】的全部子设备导入到Word模板中。
具体需求，见截图。

3190496160

Sub 生成询价函()
Application.ScreenUpdating = False
Dim i%, arr, myPath$, wdApp, wdD
Dim ar As Variant, cr As Variant
Dim br(), brr()
Dim d As Object
Set d = CreateObject("scripting.dictionary")
myPath = ThisWorkbook.Path & "\"
Set sh = ThisWorkbook.Worksheets(1)
With Sheets("数据源")
    r = .Cells(Rows.Count, 1).End(xlUp).Row
    ar = .Range("a1:k" & r)
End With
For i = 2 To UBound(ar)
    If Trim(ar(i, 2)) <> "" Then
        If Not d.exists(ar(i, 2)) Then Set d(ar(i, 2)) = CreateObject("scripting.dictionary")
        d(ar(i, 2))(i) = ""
    End If
Next i
Set wdApp = CreateObject("word.application")
wdApp.Visible = True
For Each k In d.keys
    n = 0: je = 0
    ReDim br(1 To UBound(ar), 1 To 7)
    For Each kk In d(k).keys
        n = n + 1
        br(n, 1) = n
        br(n, 2) = ar(kk, 3)
        For j = 5 To 8
            br(n, j - 2) = ar(kk, j)
        Next j
    Next kk
    FileCopy myPath & "Word模板(询价函）.docx", myPath & "询价函\" & k & ".docx"
    Set wdD = wdApp.Documents.Open(myPath & "询价函\" & k & ".docx")
    With wdApp.ActiveDocument.Tables(1)
        If n > 3 Then
            ys = n - 3
            For s = 1 To ys
                .Rows.Add
            Next s
        End If
        m = 1
        For i = 1 To n
            m = m + 1
            For j = 1 To 7
                .cell(m, j) = 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

新建文件夹.rar (44.01 KB, 下载次数: 11)

2024-6-13 10:17 上传

点击文件名下载附件

zjwieh

可以了，非常感谢