Schleife / Zelle nicht überschreiben sondern daneben einfügen

[Nixontira]

Tach leudde,

ich bräuchte einmal Hilfe mit diesem VBA-Code. Bisher sorgt dieser Code dafür, dass der Inhalt aus Zelle B3 ausgelesen wird, sodass die Teile zwischen "c" und "-" in separate Zellen daneben eingefügt werden. Die Teile zwischen "c" und "-" sind in der Form "0,5+0,35+0,6" oder "0,4+3*0,8" dabei sind da immer unterschiedlich viele Teile drin. Nun ist es leider so, dass der VBA-Code aber den Original text überschreibt und nicht direkt eine Zelle weiter nach rechts springt. Das wäre so die erste Frage wie der Code dafür angepasst werden müsste, damit Zelle B3 nicht überschrieben wird.

Und dann noch eine weitere Frage... das soll nicht nur auf Zelle B3 angewendet werden, sondern auf alle ausgefüllten Zellen die unter B3 kommen. Das bedeutet ich brauch ja irgendwie eine schleife, die solange ausgfeührt wird, solange die darunter kommenden Felder noch ausgefüllt sind.
Hat da wer ne Idee?

Hier mal mein jetziger Code:

Code:

Option Explicit

Sub Baumdurchmesser-Übersicht()
 
 Dim rngCell As Excel.Range
 Dim blnErr As Boolean
 Dim n As Long
 
 'um diese Zelle geht's
 Set rngCell = Worksheets("Tabelle1").Range("B3")
 
 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
   
   'springe n Zellen nach rechts (damit werden die ggf. eingefügten Zellen mit übersprungen)
   Set rngCell = rngCell.Offset(, n)
   
 Loop While Trim$(rngCell.Value) <> ""
 
Final:
 If Not blnErr Then
   Call MsgBox("Vorgang abgeschlossen.", vbInformation)
 Else
   Call MsgBox("Vorgang mit Fehler(n) abgeschlossen." & vbNewLine & _
               "Überprüfen sie das Ergebnis!", vbExclamation)
 End If
 
End Sub

Vielen Dank für die Hilfe und liebe Grüße!

[Igelbauer]

Hi
Für dein erstes Problem füg mal bei TextToColumns noch
  Destination:=rngCell.offset(,1)
ein.
ungetestet aber müsste klappen.

Gruss Igel

[Nixontira]

Hi
Für dein erstes Problem füg mal bei TextToColumns noch
  Destination:=rngCell.offset(,1)
ein.
ungetestet aber müsste klappen.

Gruss Igel

Erst mal vielen Dank für deine Hilfe!

Leider bringt dies keinerlei verbesserung :( Die original Zelle wird nach wie vor überschrieben. Mein Code schaut nun wie folgt aus.

Code:

Option Explicit

Sub BaumdurchmesserÜbersicht()
 
Dim rngCell As Excel.Range
Dim blnErr As Boolean
Dim n As Long
 
'um diese Zelle geht's
Set rngCell = Worksheets("Tabelle1").Range("B3")
 
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:="+", Destination:=rngCell.offset(,1))
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
   
  'springe n Zellen nach rechts (damit werden die ggf. eingefügten Zellen mit übersprungen)
  Set rngCell = rngCell.Offset(, n)
   
Loop While Trim$(rngCell.Value) <> ""
 
Final:
If Not blnErr Then
  Call MsgBox("Vorgang abgeschlossen.", vbInformation)
Else
  Call MsgBox("Vorgang mit Fehler(n) abgeschlossen." & vbNewLine & _
              "Überprüfen sie das Ergebnis!", vbExclamation)
End If
 
End Sub

Oder hab ich da was falsch ergänzt?

Vielen Dank und liebe Grüße!

[Gast 123]

Hallo

ich war am Thread nicht beteiligt, und rate mal, nachdem ich mir den Code angesehen habe, auf gut Glück!!
      Call rngCell.Resize(, n - 1).Offset(, 1).Insert(xlShiftToRight)
      rngCell.Offset(1,0).Resize(, n).Value = rngCell.Value 'kopiere Inhalt auf Zellen

auf Call kann man verzichten (verwirrt bloss, auch vor MsgBox), wenn aber hier in die neu eingefügte Zeile kopiert werden soll müste m.E. noch Offset(1,0) eingefügt werden.  Ohne Gewaehr das ich da richtig liege, probiere es einfach mal aus.

mfg  Gast 123

[Igelbauer]

Hi
leider habe ich deine Datei nicht zum testen und bin selber nur Tüftler und kein Profi.
Probier mal die Varianten
 Call .TextToColumns(rngCell.offset(,1), xlDelimited, Other:=True, OtherChar:="+")
oder
[i]Call .TextToColumns(destination:=rngCell.offset(,1), xlDelimited, Other:=True, OtherChar:="+")[/i]
 
 Wenn ich in einem anderen Land bin verstehen mich die Menschen auch ohne perfekte Grammatik, wenn ich nur die passenden Wörter weiss. Zur Not helfen auch Hände und Füsse.
Aber VBA ist da ganz schön streng

Gruss Igel

[Nixontira]

Hi
leider habe ich deine Datei nicht zum testen und bin selber nur Tüftler und kein Profi.
Probier mal die Varianten
 Call .TextToColumns(rngCell.offset(,1), xlDelimited, Other:=True, OtherChar:="+")
oder
Call .TextToColumns(destination:=rngCell.offset(,1), xlDelimited, Other:=True, OtherChar:="+")
 
 Wenn ich in einem anderen Land bin verstehen mich die Menschen auch ohne perfekte Grammatik, wenn ich nur die passenden Wörter weiss. Zur Not helfen auch Hände und Füsse.
Aber VBA ist da ganz schön streng

Gruss Igel

Danke Euch zwein! Also schließlich war es der markierte Befehl von Igelbauer, der jetzt funktioniert. Es ist nicht ganz so wie ichs mir vorstelle, weil die Ursprungszelle nicht komplett so bleibt wie ich sie eingetragen habe. ich habe meine Beispieldatei mal angefügt, vllt weiß ja einer wie der Ursprungstext genau so bleibt wie ich ihn eingetragen habe, aber trotzdem in den darauf folgenden Spalten nur die Werte zwischen den "+" Zeichen zu sehen sind.

Wichtiger wäre mir nun allerdings, dass dieser Prozess des Aufspaltens auf alle ausgefüllten Zeilen darunter auch ausgeführt wird, habt ihr dafür eine Idee? Ich bin leider ein absoluter Anfänger was Vba angeht  :20:

Liebe Grüße!