CODE-SCHNIPSEL

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