从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 文档，将这些数据按照“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个小时的无聊复制粘贴和格式化！

感谢任何帮助

- Dori

---

从您的输出需求来看，我看不出heading2和heading3有什么作用。randomdata1和randomdata2是否意味着所有列都完好无损？ - Todd Main

有点困惑你的问题。heading1、heading2、heading3、index是列标题，因为该部分意味着在Excel中表示一个具有4列和5个条目的表格。任何带有randomData *的字段只是意味着一些随机数据变量，细节并不重要。已编辑上述内容以显示我所说的所有列完整。 - Dori

因此，每个表格都有所有四列填充值就意味着“完好无损”吗？ - Todd Main

完整：未受损害的状态 - 因此每一行都是完整的，意味着它在Word文档中具有与Excel文档相同的列... - Dori

Answer 1

多瑞，

希望这能及时帮到您。

为了使此功能正常工作，您需要设置对Word的引用 - 在VBA编辑器中选择“工具”> “引用”，然后向下滚动到Microsoft Word ##，其中##是Excel'07的12.0，“03年的Excel”为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

- Doug Glancy

---

非常感谢您的回复！不幸的是，由于它昨天已经交付，所以来得有些晚了。尽管如此，还是非常感激 :) - Dori