nAbend Schnurtzer,

isNumber ist eine Benutzerdefinierte Funktion die Wahr zurückgeben soll, wenn es sich bei dem Text um eine Jahreszahl handelt. Hab ich gestern vergessen mit zu posten. Sorry.

Ja man kann die Kinder auch auf Einzelzeilen aufteilen, wenn dir das lieber ist. Und das mit dem Verlinken habe ich jetzt auch hinbekommen. Wenn du auf einen roten Text klickst, springt Excel zu der entsprechenden Hauptperson. Probiers aus. Hier der neue Code:

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 'Name
           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 'Indexnummer
           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 'Generation
           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 'Jahr von z.B.Geburt, Ableben etc
           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 'rechtsbündig
           wb.sheets(1).Cells(zei, 2).entirerow.Font.Size = 9
           merke2 = True
         ElseIf merke2 = True Then 'Text von z.B.Geburt, Ableben etc
           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

Gruß Mr. K.