Tach,
ich bräuchte einmal Hilfe mit diesem Code.
Sub Baumdurchmesser()
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
'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
Den bräuchte ich nämlich als Schleife. Momentan wird der nur auf die Zelle B1 angewendet, soll allerdings in der Spalte B so lange ausgeführt werden bis keine Einträge mehr in der Spalte B vorhanden sind. Das müsste ja mit eine Do until Schleife ablaufen und dass die condition zu Anfang geprüft wird, dass die Zelle ausgefüllt oder nicht ausgefüllt ist.
Danke für Eure Hilfe
|