Option Explicit
' ****************************************************************
' Autor/en und Original-Quelltext unter:
' https://www.online-vba.de/vba_word2xls_tables.php
' Verwendung der Quelltexte auf eigene Gefahr!
' Es gelten die Nutzungsbedingungen von https://www.online-vba.de
' ****************************************************************
Public Sub OVBAde_ExportTablesToExcel()
Dim oExcelApp As Object
Dim oExcelWorkbook As Object
Dim lZeile As Long
Dim lSpalte As Long
Dim lTable As Long
Dim oTable As Object
Dim lRememberSheetsInNewWorkbook As Long
'Zuerst wird die Excel Datei geöffnet
Set oExcelApp = CreateObject("Excel.Application")
'Nur ein leeres Blatt beim Anlegen erstellen
lRememberSheetsInNewWorkbook = oExcelApp.SheetsInNewWorkbook
oExcelApp.SheetsInNewWorkbook = 1
Set oExcelWorkbook = oExcelApp.Workbooks.Add
oExcelApp.SheetsInNewWorkbook = lRememberSheetsInNewWorkbook
oExcelApp.Visible = True
'Schleife über alle Tabellen des Dokuments
lTable = 1
For Each oTable In ActiveDocument.Tables
'Ab der zweiten Tabelle ein weiteres Blatt ergänzen
If lTable >= 2 Then
oExcelWorkbook.Sheets.Add After:=oExcelWorkbook.Sheets(oExcelWorkbook.Sheets.Count)
End If
'Tabelle übertragen für alle Zeilen und Spalten
For lZeile = 1 To oTable.Rows.Count
For lSpalte = 1 To oTable.Columns.Count
'Steuerzeichen abschneiden und Zellenwert übertragen
oExcelWorkbook.Sheets(lTable).Cells(lZeile, lSpalte) = _
Replace(Trim(CStr(oTable.Cell(lZeile, lSpalte).Range.Text)), Chr(13) & Chr(7), "")
Next lSpalte
Next lZeile
'Nächste Tabelle und Arbeitsblatt
lTable = lTable + 1
Next oTable
MsgBox "Fertig!"
'Aufräumen nicht vergessen ...
Set oTable = Nothing
Set oExcelWorkbook = Nothing
Set oExcelApp = Nothing
End Sub