Sub Linien_entfernen()
Dim i As Long, Text As String
Dim Zieldatei As Document
Set Zieldatei = Documents.Add
On Error Resume Next
For i = ThisDocument.Shapes.Count To 1 Step -1
Text = ""
Text = ThisDocument.Shapes(i).TextFrame.TextRange.Text
If Text <> "" Then Zieldatei.Range.Text = Text & Chr(13) & Zieldatei.Range.Text
ThisDocument.Shapes(i).Delete
Next i
End Sub