Sub NachExcel()
Dim wb As Object, text As String
Set wb = CreateObject("Excel.Application").Workbooks.Add
wb.Parent.Visible = True
On Error Resume Next
For i = 1 To ActiveDocument.Shapes.Count
If ActiveDocument.Shapes(i).Type = msoTextBox Then
With ActiveDocument.Shapes(i).TextFrame.TextRange
text = .text
If Not (text = Chr(13) And Len(text) = 1 Or text = "") Then
text = Replace(text, Chr(11), Chr(10))
text = Replace(text, Chr(13), "")
If .Font.Size = 12 Then
If text <> ueberschrift Then
zei = zei + 2
wb.sheets(1).Cells(zei, 2).Value = text
ueberschrift = text
ueberschriftzei = zei
wb.sheets(1).Cells(ueberschriftzei, 2).Font.Bold = True
wb.sheets(1).Cells(ueberschriftzei - 1, 1).entirerow.Font.Size = 11
End If
ElseIf merke = True Then
wb.sheets(1).Cells(ueberschriftzei, 1).Value = text
wb.sheets(1).Cells(ueberschriftzei, 1).Font.Bold = True
wb.sheets(1).Cells(ueberschriftzei, 1).Font.Size = 11
merke = False
ElseIf text Like "Generation*" Then
wb.sheets(1).Cells(ueberschriftzei - 1, 1).Value = text
wb.sheets(1).Cells(ueberschriftzei - 1, 1).entirerow.Font.Size = 8
merke = True
ElseIf isnumber(text) Then
zei = zei + 1
wb.sheets(1).Cells(zei, 2).Value = text
wb.sheets(1).Cells(zei, 2).Font.Bold = True
wb.sheets(1).Cells(zei, 2).HorizontalAlignment = -4152
wb.sheets(1).Cells(zei, 2).entirerow.Font.Size = 9
merke2 = True
ElseIf merke2 = True Then
wb.sheets(1).Cells(zei, 3).Value = text
wb.sheets(1).Cells(zei, 3).Font.Bold = True
merke2 = False
ElseIf text Like "Tochter von*" Or text Like "Sohn von*" Then
zei = zei + 1
wb.sheets(1).Cells(zei, 3).Value = text
wb.sheets(1).Cells(zei, 3).entirerow.Font.Size = 8
wb.sheets(1).Cells(zei, 3).Font.Color = 9851952
Else
zei = zei + 1
wb.sheets(1).Cells(zei, 3).Value = text
wb.sheets(1).Cells(zei, 3).entirerow.Font.Size = 8
End If
End If
End With
End If
Next i
wb.sheets(1).usedrange.entirecolumn.AutoFit
wb.sheets(1).usedrange.entirerow.AutoFit
End Sub