Trennen nach einem bestimmten Zeichen

Sub TrennenNachXZeichen()

Const lngCut As Long = 36

Dim a As Long, i As Long, lngZ As Long, Anzahl As Long

Dim vWoerter As Variant, vZeile() As Variant

Dim lastRow As Integer

Dim cell As Range

' Bildschirmaktualisierung & Mitteilungen aus

    Application.ScreenUpdating = False

    Application.DisplayAlerts = False

    'Application.EnableEvents = False



  For lngZ = Cells(Rows.Count, 4).End(xlUp).Row To 3 Step -1

    vWoerter = Split(Application.Substitute(Cells(lngZ, 4).Value, vbLf, " "), " ")

    If UBound(vWoerter) > -1 Then

      ReDim vZeile(0)

      a = 0

      vZeile(0) = vWoerter(0)

       For i = 0 To UBound(vWoerter) - 1

          If Len(vZeile(a)) + Len(vWoerter(i + 1)) > lngCut Then

              a = a + 1

              ReDim Preserve vZeile(a)

              vZeile(a) = vWoerter(i + 1)

          Else

              vZeile(a) = vZeile(a) & " " & vWoerter(i + 1)

          End If

      Next i

      If UBound(vZeile) > 0 Then

        Rows(lngZ + 1).Resize(UBound(vZeile)).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove

        vZeile = Application.Transpose(vZeile)

        Cells(lngZ, 4).Resize(UBound(vZeile)).Value = vZeile

      End If

    End If

  Next lngZ

End Sub