Auto erstellen von Tabellen in Word aus einem Excel-Dokument

Question

Ich habe einen Datensatz in Excel, der wie unten (im CSV-Format) aussieht

heading1, heading2, heading3, index
A , randomdata1, randomdata2, 1
A , randomdata1, randomdata2, 2
A , randomdata1, randomdata2, 3
B , randomdata1, randomdata2, 4
C , randomdata1, randomdata2, 5

Ich möchte automatisch ein Word-Dokument erstellen können, das diese Daten präsentiert, wobei die Informationen nach heading1 gruppiert in separate Tabellen aufgeteilt sind. Das Word-Dokument könnte also wie folgt aussehen

Tabelle A
heading1, heading2, heading3, index
A , randomdata1, randomdata2, 1
A , randomdata1, randomdata2, 2
A , randomdata1, randomdata2, 3

Tabelle B 
heading1, heading2, heading3, index
B , randomdata1, randomdata2, 4

Tabelle C 
heading1, heading2, heading3, index
C , randomdata1, randomdata2, 5

Könnte mir bitte jemand dabei helfen, da es etwa 20 Stunden sehr langweilige Kopier- und Einfügearbeit sparen würde!

Vielen Dank für jegliche Hilfe

Answer 1

Dori,

Hoffentlich kommt dies rechtzeitig zur Hilfe.

Um dies zu ermöglichen, müssen Sie eine Referenz auf Word setzen - im VBA-Editor wählen Sie Tools>Verweise und scrollen Sie nach unten zu Microsoft Word ##, wobei ## für 12.0 für Excel '07, 11.0 für Excel '03, etc. steht. Außerdem sollte das Blatt nicht gefiltert sein, wenn Sie dies ausführen, und obwohl Sie nicht nach Überschrift 1 sortieren müssen, habe ich angenommen, dass Sie es haben.

Der Code geht davon aus, dass Ihre Liste mit einer Überschrift in Zelle A1 beginnt. Wenn dies nicht der Fall ist, sollten Sie es so ändern. Es geht auch davon aus, dass Ihre letzte Spalte D ist. Sie können dies in der Zeile am Ende anpassen, die mit ".Copy" beginnt.

Sub KopiereExcelDatenNachWord()

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