Hallo zusammen,

ich habe einen Excel-VBA-Code geschrieben, der eine word-Datei öffnet. In dieser sind mehere identisch aufgebaute Tabellen mit 2 Spalten: in der 1. die jeweilige Bezeichnung des Inhalts (="Überschrift"), in der 2. der eigentliche Inhalt. Dieser variiert von Tabelle zu Tabelle. (Dieser Inhalt soll in die Excel kopiert werden)

Mein Makro öffnet die Word, und zieht dort aus jeder Tabellenzeile die Inhalte aus der 2. Spalte und trägt sie in die Excel ein. Hier sind die Bezeichnungen aus der Word (1. Spalte), jeweils die Spaltenüberschrift . Ich lasse das ganze Zeile für Zeile, Tabelle für Tabelle ablaufen. Und hier kommt ihr ins Spiel: ich bin mir sicher, dass das automatisiert gehen kann:

1. füge Inhalte aus der 1. Word-Tabelle in die 2. Zeile der Excel an den jeweils richtigen Platz (=richtige Spalte) bis Tabellenende, dann: 

2. wechsle in die nächste Zeile der Excel und beginne mit der nächsten Tabelle im Word-Dokument (füge Inhalte aus der 2. Tabelle in die 3. Zeile der Excel an den jeweils richtigen Platz(=Spalte) bis Tabellenende)...

bis: keine zu bearbeitende Tabelle in diesem Worddokument vorhanden ist. Ggf. hier noch eine MsgBox mit der Meldung "keine weitere Tabelle mehr vorhanden".

Dann greift mein VBA-Code wieder.

Hier mein umständlicher Code: 

Sub ImportVonWordInExcelAusTabelle()

'Variable definieren
Dim w As Word.Application
Dim d As Word.Document
Dim ws As Worksheet
Dim i As Long


'geöffnete Word-Vorlage als aktives Dokument kennzeichnen
Set ws = ActiveSheet
On Error Resume Next
Set w = GetObject("word.application")
If Err.Number <> 0 Then
    Set w = CreateObject(Word.Application)
    Err.Clear

Set w = CreateObject("word.application")
w.Visible = True

'word öffnen
w.Documents.Open "C:\Users\VBA\IDEE 2_mit 2spTabelle.docx"

'dokument aktivieren, 1. Tabelle: Parameter finden und exportieren
Set d = w.ActiveDocument
'i = ws.Cells(ws.Cells.Rows.Count, 1).End(xlUp).Row + 1
Worksheets(1).Cells(2, 1).Value = d.Tables(1).Cell(Row:=1, Column:=2)
Worksheets(1).Cells(2, 2).Value = d.Tables(1).Cell(Row:=2, Column:=2)
Worksheets(1).Cells(2, 3).Value = d.Tables(1).Cell(Row:=3, Column:=2)
Worksheets(1).Cells(2, 4).Value = d.Tables(1).Cell(Row:=4, Column:=2)


'nächste Tabelle
Worksheets(1).Cells(3, 1).Value = d.Tables(2).Cell(Row:=1, Column:=2)
Worksheets(1).Cells(3, 2).Value = d.Tables(2).Cell(Row:=2, Column:=2)
Worksheets(1).Cells(3, 3).Value = d.Tables(2).Cell(Row:=3, Column:=2)
Worksheets(1).Cells(3, 4).Value = d.Tables(2).Cell(Row:=4, Column:=2)
.
.
.

'mache das, bis keine neue Tabelle mehr vorhanden ist


d.Close False
Set d = Nothing
w.Quit
Set w = Nothing
Set ws = Nothing

End Sub

Freue mich über eure Anregungen

Arbeite mit Office 365, Windows 11, Gruß, Gäbi