Okay,

nun führt er es wieder aus, aber nicht in Schleife sondern nur eine Zeile.

In Spalte B steht momentan der linke untere Teil. nach Ausführung des Codes soll zeile B überschrieben werden und die Teile wie dargestellt auf einezelne Spalten aufgeteilt werden. Bis jetzt wird das aber nur auf die erste Zeile ausgeführt und nicht alle ausgefüllten.

Sub Baumdurchmesser4()
        
Dim rngCell As Excel.Range
Dim blnErr As Boolean
Dim n As Long
      
'um diese Zelle geht's
Set rngCell = Worksheets("Tabelle1").Range("B1")
      
'On Error GoTo Final
     With rngCell
    'reduziere den Zelleninhalt auf den Teil zwischen 'c' und '-'
    .Value = Mid$(.Value, InStr(.Value, "c") + 1, InStr(.Value, "-") - InStr(.Value, "c") - 1)
    'verw. Excel-Funktion: Daten -> TextInSpalten
    Call .TextToColumns(rngCell, xlDelimited, Other:=True, OtherChar:="+")
  End With
  On Error GoTo 0 'Fehlerunterdrückung: AUS
       
  'im folgenden wird solange Zelle um Zelle weiter nach rechts gesprungen
  'bis jene Zelle keinen Inhalt mehr hat, dabei wird ggf. der Faktor vor '*' behandelt
Do While rngCell <> ""
    'schaue ob Zelle ein '*' beinhaltet
    n = InStr(1, rngCell.Value, "*")
         
    'als nächstes wird ggf. der Zelleninhalt zerlegt
    'Inhalt Bsp: 3*0,5 wird zu: [n:=3] * [Ausdruck:=0,5]
    'entsprechend zu n werden zustäzliche Zellen eingefügt und mit Ausdruck belegt
    '(andere Daten werden dabei nach rechts verschoben)
         
    If n > 0 Then
      On Error Resume Next 'Fehlerunterdrückung: AN
      n = Left(rngCell.Value, n - 1)
      If Err.Number <> 0 Then
        On Error GoTo 0 'Fehlerunterdrückung: AUS
        blnErr = True
        n = 1
      ElseIf n > 1 Then
        'Zelleninhalt um den Ausdruck 'n*' kürzen
        rngCell.Value = Mid(rngCell.Value, InStr(1, rngCell.Value, "*") + 1)
        rngCell.Value = rngCell.Value * 1 'versuche Zelleninhalt als Zahl zu formatieren
        On Error GoTo 0 'Fehlerunterdrückung: AUS
        'füge zusätzlichen Zellen ein
        Call rngCell.Resize(, n - 1).Offset(, 1).Insert(xlShiftToRight)
        rngCell.Resize(, n).Value = rngCell.Value 'kopiere Inhalt auf Zellen
      End If
    Else
      n = 1
    End If
    Set rngCell = rngCell.Offset(0, 1)  'rngCell um Offset(Zeile,Spalte) versetzen
 
Final:
Loop

End Sub