Hallo nochmal,

also warum For Each hier nicht anspringt kann ich wirklich nicht sagen. Sollte eigentlich klappen. Aber irgendwie befinden sich neben den Linien und Textboxen offenbar noch andere unsichtbare Shapes im Dokument, die sogar schon beim Festellen des typs einen Fehler verursachen. Hier kommt man wirklich nur mit On error weiter.

Aber du willst ja nur die Texte aus den Textboxen ins Excel transferieren. Hier erstmal der aktuelle Stand des Codes. Probier ihn mal aus, ob das ungefähr in die Richtung geht, die du dir vorstellst.

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 '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 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

Hab gesehen, dass du außerdem einige Kinder mit bereits bestehenden Personen verlinken willst. Auch das wäre theorethisch möglich. Da bei den Kindern aber zusätzlicher Text enthalten ist, ist kein 1:1 Vergleich möglich. Vielleicht fällt mir in den nächsten Tagen noch was dazu ein.

Gruß Mr. K.