Sub Test()
Dim cL As Object
Dim sPfad As String
Dim appWord As Object
Dim i As Long
Dim a As Long
Dim t As Long
Dim counter As Long
Dim cDir As String
Dim v As String
Set appWord = CreateObject("Word.Application")
sPfad = "C:\temp\"
cDir = Dir(sPfad & "*.doc")
counter = 0
t = 3
i = 0
appWord.Documents.Open(sPfad & cDir, ReadOnly = True).Application.Visible = False
ActiveWorkbook.ActiveSheet.Cells(5, 5) = Left(v, Len(v) - 2)
Do While cDir <> ""
appWord.Documents.Open(sPfad & cDir, ReadOnly = True).Application.Visible = False
v = appWord.ActiveDocument.Tables(2).Cell(1, 1).Range.Text
ActiveWorkbook.ActiveSheet.Cells(t + counter, 1) = Left(v, Len(v) - 2)
For a = 2 To 6
i = i + 1
For Each cL In appWord.ActiveDocument.Tables(4).Columns(a).Cells
i = i + 1
ActiveWorkbook.ActiveSheet.Cells(t + counter, i) = Left(cL.Range.Text, Len(cL.Range.Text) - 2)
Next
Next a
appWord.ActiveDocument.Close savechanges:=False
cDir = Dir
counter = counter + 1
i = 0
Loop
Set appWord = Nothing
End Sub