如何将Excel中同编号关联多行数据批量导入Word表单

前期准备 #

• 调整你的Word表单模板：行号显示位置添加标题为rowNum的内容控件，多条关联记录的展示位置插入表格，给该表格添加书签名为recordTable，表格预先设置好「字母」「日期」表头，仅保留1行空白数据行即可。
• 提前将Excel的Sheet1数据按第一列（行号）升序排序，避免分组顺序混乱。
• 打开Word VBA编辑器，依次点击「工具」→「引用」，勾选「Microsoft Excel xx.x Object Library」（xx.x为你本地安装的Office版本号）。

核心VBA代码 #

' 两种运行模式二选一，不需要的模式注释掉即可
Sub 批量导入Excel行号关联数据()
    Dim objExcel As New Excel.Application
    Dim exWb As Excel.Workbook, ws As Excel.Worksheet
    Dim lastRow As Long, i As Long
    Dim rowGroupDict As Object, rowKey As Variant, recordItem As Variant
    Dim targetDoc As Document, recordTable As Table, newRow As Row
    Dim savePath As String
    
    ' 自定义路径配置，替换为你本地的实际路径
    Const EXCEL_FILE_PATH = "C:\Users\testing.xlsm"
    Const WORD_TEMPLATE_PATH = "C:\Users\你的表单模板路径.dotx"
    savePath = "C:\Users\表单导出存储目录\" ' 末尾要加反斜杠
    
    ' 初始化字典用于行号分组
    Set rowGroupDict = CreateObject("Scripting.Dictionary")
    objExcel.Visible = False ' 后台运行Excel不弹出窗口
    
    ' 读取Excel数据并按行号分组
    Set exWb = objExcel.Workbooks.Open(EXCEL_FILE_PATH)
    Set ws = exWb.Sheets("Sheet1")
    lastRow = ws.Cells(ws.Rows.Count, 1).End(-4162).Row ' 获取数据最后一行行号
    
    For i = 2 To lastRow ' 跳过第一行表头
        rowKey = ws.Cells(i, 1).Value
        If Not rowGroupDict.Exists(rowKey) Then
            rowGroupDict.Add rowKey, New Collection ' 新建分组存储该行列的所有关联记录
        End If
        ' 存储当前行的字母+日期数据
        rowGroupDict(rowKey).Add Array(ws.Cells(i, 2).Value, ws.Cells(i, 3).Value)
    Next i
    
    ' ==============================================
    ' 模式1：为每个不同行号生成独立的Word表单
    ' ==============================================
    For Each rowKey In rowGroupDict.Keys
        ' 基于模板新建空白表单
        Set targetDoc = Documents.Add(WORD_TEMPLATE_PATH)
        ' 填充行号
        targetDoc.SelectContentControlsByTitle("rowNum").Item(1).Range.Text = rowKey
        Set recordTable = targetDoc.Bookmarks("recordTable").Range.Tables(1)
        ' 填充该行列所有关联的字母、日期数据
        For Each recordItem In rowGroupDict(rowKey)
            Set newRow = recordTable.Rows.Add
            newRow.Cells(1).Range.Text = recordItem(0)
            newRow.Cells(2).Range.Text = Format(recordItem(1), "yyyy-mm-dd") ' 可自定义日期格式
        Next
        ' 删除模板预留的空白数据行
        recordTable.Rows(2).Delete
        ' 保存并关闭当前表单
        targetDoc.SaveAs2 savePath & "行号" & rowKey & "_表单.docx"
        targetDoc.Close
    Next rowKey
    
    ' ==============================================
    ' 模式2：所有行号数据批量填充到同一个Word表单
    ' 不需要的话注释掉上述模式1，取消下方代码注释即可
    ' ==============================================
    ' Set targetDoc = Documents.Add(WORD_TEMPLATE_PATH)
    ' Dim insertRange As Range
    ' Set insertRange = targetDoc.Content
    ' insertRange.Collapse Direction:=wdCollapseEnd
    '
    ' For Each rowKey In rowGroupDict.Keys
    '    insertRange.InsertAfter "行号：" & rowKey & vbCrLf
    '    ' 插入该组的记录表格
    '    Set recordTable = targetDoc.Tables.Add(insertRange, 1, 2)
    '    recordTable.Cell(1, 1).Range.Text = "字母"
    '    recordTable.Cell(1, 2).Range.Text = "日期"
    '    ' 填充关联记录
    '    For Each recordItem In rowGroupDict(rowKey)
    '        Set newRow = recordTable.Rows.Add
    '        newRow.Cells(1).Range.Text = recordItem(0)
    '        newRow.Cells(2).Range.Text = Format(recordItem(1), "yyyy-mm-dd")
    '    Next
    '    insertRange.Collapse Direction:=wdCollapseEnd
    '    insertRange.InsertAfter vbCrLf & "--------------------------" & vbCrLf
    ' Next rowKey
    ' targetDoc.SaveAs2 savePath & "所有行号汇总表单.docx"
    
    ' 释放资源
    exWb.Close SaveChanges:=False
    objExcel.Quit
    Set exWb = Nothing
    Set objExcel = Nothing
    Set rowGroupDict = Nothing
    MsgBox "数据导入完成，已存储到指定目录。"
End Sub

注意事项 #

• 运行代码前请确认所有路径配置正确，保存导出文件的目录需要提前创建。
• 如果你不需要日期格式化，可以删除代码中的Format函数，直接赋值recordItem(1)即可。
• 若表单模板中使用的是标签控件而非内容控件，将填充行号的代码替换为ThisDocument.row.Caption = rowKey即可。

内容的提问来源于stack exchange，提问作者Codewriter123