Автоматическое создание таблиц в Word из документа Excel

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

Я хочу иметь возможность автоматически создавать текстовый документ, который представляет эти данные, информацию, сгруппированную по заголовку 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 ##, где ## - 12.0 для Excel '07, 11.0 для Excel '03 и т.д. Кроме того, лист не должен фильтроваться при запуске, и хотя вам не нужно сортировать по заголовку 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