从 Excel 文档在 Word 中自动创建表格

Question

我在 Excel 中有一组数据，如下所示（CSV 格式），

heading1, heading2, heading3, index
A , randomdata1, randomdata2, 1
A , randomdata1, randomdata2, 2
A , randomdata1, randomdata2, 3
B , randomdata1, randomdata2, 4
C , randomdata1, randomdata2, 5

我希望能够自动构建一个 Word 文档来显示这些数据，其中信息按标题 1 分组到单独的表中。所以文档这个词就像“

Table A
heading1, heading2, heading3, index
A , randomdata1, randomdata2, 1
A , randomdata1, randomdata2, 2
A , randomdata1, randomdata2, 3

Table B 
heading1, heading2, heading3, index
B , randomdata1, randomdata2, 4

Table C 
heading1, heading2, heading3, index
C , randomdata1, randomdata2, 5

请有人帮我解决这个问题”，因为它将节省大约 20 个小时非常无聊的复制和打印时间。粘贴并格式化！

感谢您的帮助

Answer 1

多丽，

希望这能及时提供帮助。

为此，您需要设置对 Word 的引用 - 在 VBA 编辑器中选择“工具”>“引用”并向下滚动到 Microsoft Word ##，其中 ## 对于 Excel '07 为 12.0，对于 Excel '03 为 11.0，等等。另外，当您运行此命令时，不应过滤工作表，尽管您不需要按标题 1 排序，但我假设您已经这样做了。

该代码假定您的列表以单元格 A1 中的标题开始。如果这不是真的，你应该这样做。它还假定 D 中的最后一列。您可以在以“.Copy”开头的行末尾调整该值。

Sub CopyExcelDataToWord()

Dim wsSource As Excel.Worksheet
Dim cell As Excel.Range
Dim collUniqueHeadings As Collection
Dim lngLastRow As Long
Dim i As Long
Dim appWord As Word.Application
Dim docWordTarget As Word.Document

Set wsSource = ThisWorkbook.Worksheets(1)
With wsSource
    lngLastRow = .Range("A" & Rows.Count).End(xlUp).Row
    Set collUniqueHeadings = New Collection
    For Each cell In .Range("A2:A" & lngLastRow)
        On Error Resume Next
        collUniqueHeadings.Add Item:=cell.Value, Key:=cell.Value
        On Error GoTo 0
    Next cell
End With
Set appWord = CreateObject("Word.Application")
With appWord
    .Visible = True
    Set docWordTarget = .Documents.Add
    .ActiveDocument.Select
End With
For i = 1 To collUniqueHeadings.Count
    With wsSource
        .Range("A1").AutoFilter Field:=1, Criteria1:=collUniqueHeadings(i)
        .Range("A1:D" & lngLastRow).Copy
    End With
    With appWord.Selection
        .PasteExcelTable linkedtoexcel:=False, wordformatting:=True, RTF:=False
        .TypeParagraph
    End With
Next i

For i = 1 To collUniqueHeadings.Count
    collUniqueHeadings.Remove 1
Next i
Set docWordTarget = Nothing
Set appWord = Nothing

End Sub