Sub Baumdurchmesser()
    
  Dim rngCell As Excel.Range
  Dim blnErr As Boolean
  Dim n As Long
    
  Do While rngCell <> ""
  Set rngCell = rngCell.Offset(0, 1)
    
  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
    '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
Loop

End Sub


okay irgendwas hab ich falsch gemacht. er meckert am ende, dass "Loop ohne Do"