Function TrenneZelle(z As Range) As Boolean
Dim s1 As String, s2 As String, i As Long
i = InStr(z.Value, Chr(10))
If i = 0 Then TrenneZelle = False: Exit Function
s1 = Left(z.Value, i - 1)
s2 = Mid(z.Value, i + 1)
With z
.Value = s1
.EntireRow.AutoFit
.Offset(1, 0).Value = s2
End With
TrenneZelle = True
End Function
Sub Trennen()
Dim erg As Boolean
Dim zelle As Range
Set zelle = ActiveCell 'hier: aktive zelle wird getrennt
Do
erg = TrenneZelle(zelle)
If erg = False Then Exit Do
Set zelle = zelle.Offset(1, 0)
Loop
End Sub
Die Datei https://www.herber.de/bbs/user/24482.xls wurde aus Datenschutzgründen gelöscht
ich habe den Code nochmals geändert, so dass die Zeilen eingefügt und nicht überschrieben werden.