Und doch nochmal 'ne Korrektur, ...sorry
Kann halt schlecht testen,, da ich nicht weiß, wie dein Zellinhalt ist (+Sprungmarke)
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
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
|