Sub NachExcel()
Dim wb As Object, text As String
Set wb = CreateObject("Excel.Application").Workbooks.Add
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 InStr(text, Chr(10)) Then
arr = Split(text, Chr(10))
For Each txt In arr
zei = zei + 1
wb.sheets(1).Cells(zei, 3).Value = txt
wb.sheets(1).Cells(zei, 3).entirerow.Font.Size = 8
If text Like "Tochter von*" Or text Like "Sohn von*" Or merke3 = True Then
wb.sheets(1).Cells(zei, 3).Font.Color = 9851952
If merke3 = True Then merke3 = False Else merke3 = True
End If
Next txt
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
For i = 1 To wb.sheets(1).usedrange.Rows.Count
If wb.sheets(1).Cells(i, 2) <> "" And wb.sheets(1).Cells(i, 1) <> "" Then
Set lnk = wb.sheets(1).Cells.Find(wb.sheets(1).Cells(i, 2))
If Not lnk Is Nothing Then
If lnk.Address <> wb.sheets(1).Cells(i, 2).Address Then
lnk.Value = lnk.Value & " Person " & wb.sheets(1).Cells(i, 1)
lnk.Hyperlinks.Add Anchor:=lnk, Address:="", SubAddress:=wb.sheets(1).Name & "!" & wb.sheets(1).Cells(i, 2).Address, _
TextToDisplay:=lnk.Value
lnk.Font.Color = 255
End If
End If
End If
Next i
wb.sheets(1).usedrange.entirecolumn.AutoFit
wb.sheets(1).usedrange.entirerow.AutoFit
wb.Parent.Visible = True
End Sub
Function isnumber(text As String) As Boolean
On Error Resume Next
isnumber = CLng(text) > 0
End Function