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

у меня есть набор данных в 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 часов очень скучной копии и вставки и форматирования!

Спасибо за помощь

1 ответов


Дори,

надеюсь, что это время, чтобы помочь.

для этого вам нужно установить ссылку на Word-в Редакторе VBA выберите инструменты>ссылки и прокрутите вниз до Microsoft Word ##, где ## - 12.0 для Excel '07,11.0 для Excel' 03 и т. д. Кроме того, лист не должен фильтроваться при запуске этого, и хотя вам не нужно сортировать по заголовку 1, я предположил, что у вас есть.

код предполагает, что ваш список начинается с заголовка в ячейку A1. Если это неправда, ты должен сделать так. Он также предполагает, что ваш последний столбец В D. Вы можете настроить это в строке к концу, который начинается с ".Копия."

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