Sub Baumdurchmesser2()
     
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
Do While rngCell <> ""
     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
    '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
Loop
 
End Sub

der sagt mir nach wie vor, dass Loop ohne do :(