从Excel文档自动在Word中创建表 [英] Auto creating tables in Word from an Excel document

问题描述

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

I have a set of data in Excel which is like the below (in CSV format)

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分组的信息)呈现到单独的表中.所以文档一词就像

I want to be able to auto build a word document that presents this data, which the information grouped by heading1, into separate tables. So the word document would be like

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个小时的无聊复制&粘贴和格式化！

Please could someone help me with this as it will save about 20 hours of very boring copy & pasting and formatting!

感谢您的帮助

推荐答案

Dori，

希望能及时为您提供帮助.

Hope this is in time to help.

要执行此操作，您需要设置对Word的引用-在VBA编辑器中，选择工具">引用"，然后向下滚动至Microsoft Word ##，其中对于Excel '07，##是12.0，对于Excel '03，1#是11.0，依此类推. .此外，运行此表时不应对其进行过滤，尽管您无需按标题1进行排序，但我认为您已经做到了.

For this to work you need to set a reference to Word - in the VBA editor choose Tools>References and scroll down to Microsoft Word ##, where ## is 12.0 for Excel '07, 11.0 for Excel '03, etc. Also, the sheet shouldn't be filtered when you run this, and although you don't need to sort by heading 1, I assumed that you have.

代码假定您的列表以单元格A1中的标题开头.如果那不是真的，那么你应该这样做.它还假定您在D中的最后一列.您可以在以".Copy"开头的行中对其进行调整.

The code assumes that your list starts with header in cell A1. IF that's not true you should make it so. It also assumes that your last column in D. You can adjust that in the line towards the end that starts with ".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

这篇关于从Excel文档自动在Word中创建表的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！