Sub Test()
Dim t As Table
Dim r As Row
Dim cL As Cell
Dim sPfad As String
Dim sFile As String
Dim appExcel As Object
Dim sWorkbook As Object
Dim i As Long
Dim counter As Long
Dim strWorkbook As String
Dim j As Long
Dim bLetzte As Boolean
Dim col As Column
sPfad = "C:\Dokumente und Einstellungen\bgrundey\Eigene Dateien"
sFile = "Test.xls"
Set appExcel = CreateObject("Excel.Application")
Set sWorkbook = appExcel.Workbooks.Add
sWorkbook.ActiveSheet.Cells.WrapText = True
bLetzte = False
With sWorkbook.ActiveSheet.Rows("2:2")
.FreezePanes = True
End With
counter = 0
For Each t In ActiveDocument.Tables
i = 0
j = 0
If counter > 1 Then
For Each r In t.Rows
For Each cL In r.Cells
If (InStr(1, cL.Range.Text, "Begriff") = 1) Then
bLetzte = True
End If
i = i + 1
If (i Mod 2 = 0) And (bLetzte = False) Then
j = i - (i \ 2)
sWorkbook.ActiveSheet.Cells(counter, j) = Left(cL.Range.Text, Len(cL.Range.Text) - 2)
End If
Next
Next
End If
counter = counter + 1
Next
sWorkbook.SaveAs sPfad & "\" & sFile
sWorkbook.Close True
Set appExcel = Nothing
End Sub