Sub WordToExcel()
Dim MeinExcel As Excel.Application
Dim i As Long
Dim WordDokuPfad As String
Dim ExcelDokuPfad As String
Dim WordDatei As String
Dim Absatz As String
Dim ZeilenZähler1 As Long
Dim ZeilenZähler2 As Long
 
Rem Hier den Pfad zu den Word-Dokumenten eingeben
WordDokuPfad = "C:\DokuProbe1\"
Rem Hier den Pfad zu den Excel-Dokumenten eingeben (leeres Verzeichnis)
ExcelDokuPfad = "C:\DokuProbe2\"
Rem ACHTUNG !!! Beide Verzeichnisse müssen unterschiedlich sein !!!
 
On Error Resume Next
Set MeinExcel = GetObject(, "Excel.Application")
If MeinExcel Is Nothing Then
    Set MeinExcel = New Excel.Application
End If
MeinExcel.Visible = True
On Error GoTo 0
 
WordDatei = Dir(WordDokuPfad)
While WordDatei <> ""
    MeinExcel.Workbooks.Add
    Documents.Open FileName:=WordDokuPfad & WordDatei
    ZeilenZähler1 = 0
    ZeilenZähler2 = 0
    For i = 1 To ActiveDocument.Paragraphs.Count
        ActiveDocument.Paragraphs(i).Range.Select
        Selection.MoveLeft Unit:=wdCharacter, Count:=1, Extend:=wdExtend
        Absatz = Selection.Range.Text
        If Selection.Information(wdWithInTable) Then
            ZeilenZähler2 = Selection.Information(wdMaximumNumberOfRows)
            MeinExcel.Range(Chr$(Selection.Information( _
              wdStartOfRangeColumnNumber) + 64) & Selection.Information( _
              wdStartOfRangeRowNumber) + ZeilenZähler1).Select
            MeinExcel.ActiveCell.FormulaR1C1 = Absatz
        Else
            ZeilenZähler1 = ZeilenZähler1 + ZeilenZähler2
            ZeilenZähler2 = 0
            ZeilenZähler1 = ZeilenZähler1 + 1
            MeinExcel.Range("A" & ZeilenZähler1).Select
            MeinExcel.ActiveCell.FormulaR1C1 = Absatz
        End If
    Next
    ActiveDocument.Close
    MeinExcel.ActiveWorkbook.SaveAs ExcelDokuPfad & Mid$(WordDatei, 1, Len( _
      WordDatei) - 3) & "xls"
    MeinExcel.ActiveWorkbook.Close
    WordDatei = Dir
Wend
MeinExcel.Quit
Set MeinExcel = Nothing
MsgBox "Ich bin fertig."
End Sub