从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文档，将word（按heading1分组的信息）显示在单独的表中。 所以word文档就像

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