Variables Trennen von Spalten

Hallo liebe Excelfreunde,
ich muss ein VBA makro schreiben habe jedoch nach längerem Rumprobieren leider immer noch keinen ansatz. Um kurz mein Problem zu erläutern:
Das Ausgangssheet hat folgendes Format:
A B C E F G I J K L
1 A1 B1 C1 E1 F1 01|02 1 1 1 1
2 A2 B2 C2 E2 F2 01|02|03 2 2 2 2
2 A3 B3 C3 E3 F3 01 02|03 3 3 3
usw.
und muss in einem neuen sheet in folgendes Format gebracht werden:
A B C E F G I J K L
1 A1 B1 C1 E1 F1 01 1 1 1 1
2 A1 B1 C1 E1 F1 02 1 1 1 1
3 A2 B2 C2 E2 F2 01 2 2 2 2
4 A2 B2 C2 E2 F2 02 2 2 2 2
5 A2 B2 C2 E2 F2 03 2 2 2 2
6 A3 B3 C3 E3 F3 01 02 3 3 3
7 A3 B3 C3 E3 F3 01 03 3 3 3
Zu beachten ist, dass die Anzahl der Elemente die durch einen strich getrennt sind variabel ist. Ebenfalls hat Excel leider standardmäßig eine einstellung das aus 01 der eintrag 1 gemacht wird. D.h. die Zellen müssen mitformatiert werden.
Die Anzahl der Zeilen ist Variabel. Ich lade noch ein kleines Excelsheet hoch welches mein Problem etwas anschaulicher macht.
https://www.herber.de/bbs/user/92755.xlsx
Ich hoffe das mir jemand helfen kann.

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Option Explicit Dim varKontakt Sub Trennen() Dim lngLetzte As Long Dim lngZeile As Long Dim lngStart As Long lngLetzte = IIf(IsEmpty(Cells(Rows.Count, 1)), Cells(Rows.Count, 1).End(xlUp).Row, Rows. _ Count) For lngZeile = lngLetzte To 2 Step -1 If InStr(Cells(lngZeile, 8), "|") > 0 Then varKontakt = Split(Cells(lngZeile, 8).Text, "|") lngStart = lngZeile + UBound(varKontakt) - 1 Ausfuehren lngZeile, lngStart, 8 ElseIf InStr(Cells(lngZeile, 9), "|") > 0 Then varKontakt = Split(Cells(lngZeile, 9).Text, "|") lngStart = lngZeile + UBound(varKontakt) - 1 Ausfuehren lngZeile, lngStart, 9 End If Next lngZeile Columns("H:I").AutoFit End Sub Sub Ausfuehren(lngZ As Long, lngSt As Long, intSpalte As Integer) Rows(lngZ & ":" & lngSt).Insert Rows(lngSt + 1).Copy Rows(lngZ & ":" & lngSt) Cells(lngZ, intSpalte).Resize(UBound(varKontakt) + 1, 1).NumberFormat = "00000" Cells(lngZ, intSpalte).Resize(UBound(varKontakt) + 1, 1) = Application.Transpose(varKontakt) _ End Sub

Option Explicit Sub Auflösen() Dim LZeile As Long, Zeile As Long, ELZeile As Long, EZeile As Long Dim A As String, B As String, C As String, D As String Dim E As String, F As String, G As String, H As String Dim I As String, J As String, K As String, L As String Dim ArrH As Variant Dim ArrI As Variant With Worksheets("Original") LZeile = .Cells(Rows.Count, 1).End(xlUp).Row ELZeile = 2 For Zeile = 2 To LZeile A = .Cells(Zeile, 1) B = .Cells(Zeile, 2) C = .Cells(Zeile, 3) D = .Cells(Zeile, 4) E = .Cells(Zeile, 5) F = .Cells(Zeile, 6) G = .Cells(Zeile, 7) H = .Cells(Zeile, 8) I = .Cells(Zeile, 9) J = .Cells(Zeile, 10) K = .Cells(Zeile, 11) L = .Cells(Zeile, 12) ArrH = Split(H, "|") ArrI = Split(I, "|") Select Case UBound(ArrH) > UBound(ArrI) Case Is = True With Worksheets("Formatiert FINAL") For EZeile = 0 To UBound(ArrH) .Cells(ELZeile, 1) = A .Cells(ELZeile, 2) = B .Cells(ELZeile, 3) = C .Cells(ELZeile, 4) = D .Cells(ELZeile, 5) = E .Cells(ELZeile, 6) = F .Cells(ELZeile, 7) = G .Cells(ELZeile, 8) = CStr("'" & ArrH(EZeile)) .Cells(ELZeile, 9) = I .Cells(ELZeile, 10) = J .Cells(ELZeile, 11) = K .Cells(ELZeile, 12) = L ELZeile = ELZeile + 1 Next EZeile End With Case Is = False With Worksheets("Formatiert FINAL") For EZeile = 0 To UBound(ArrI) .Cells(ELZeile, 1) = A .Cells(ELZeile, 2) = B .Cells(ELZeile, 3) = C .Cells(ELZeile, 4) = D .Cells(ELZeile, 5) = E .Cells(ELZeile, 6) = F .Cells(ELZeile, 7) = G .Cells(ELZeile, 8) = H .Cells(ELZeile, 9) = CStr("'" & ArrI(EZeile)) .Cells(ELZeile, 10) = J .Cells(ELZeile, 11) = K .Cells(ELZeile, 12) = L ELZeile = ELZeile + 1 Next EZeile End With End Select Next Zeile End With End Sub

Hi,
hier nochmal der Code mit einigen Kommentaren - vielleicht wird dann klarer, was abläuft:

Dim varKontakt  ' Variable für die aufgesplitteten Zellinhalte
Sub Trennen()
Dim lngLetzte As Long
Dim lngZeile As Long
Dim lngStart As Long
' letzte belegte Zeile in Spalte A
lngLetzte = IIf(IsEmpty(Cells(Rows.Count, 1)), _
Cells(Rows.Count, 1).End(xlUp).Row, Rows.Count)
' Schleife von letzter belegten Zeile bis Zeile 2 aufwärts
For lngZeile = lngLetzte To 2 Step -1
' Spalte H enthält "|"
If InStr(Cells(lngZeile, 8), "|") > 0 Then
' Zellinhalt der laufenden Zeile aufsplitten
varKontakt = Split(Cells(lngZeile, 8).Text, "|")
' Startzeile für den einzufügenden Bereich ermitteln
' aus laufender Zeile und Anzahl der gesplitteten Werte
lngStart = lngZeile + UBound(varKontakt) - 1
' Unterprozedur aufrufen mit laufender Zeile, Startzeile und Spalte 8 (H)
Ausfuehren lngZeile, lngStart, 8
' Spalte I enthält "|"
ElseIf InStr(Cells(lngZeile, 9), "|") > 0 Then
' Zellinhalt der laufenden Zeile aufsplitten
varKontakt = Split(Cells(lngZeile, 9).Text, "|")
' Startzeile für den einzufügenden Bereich ermitteln
' aus laufender Zeile und Anzahl der gesplitteten Werte
lngStart = lngZeile + UBound(varKontakt) - 1
' Unterprozedur aufrufen mit laufender Zeile, Startzeile und Spalte 9 (I)
Ausfuehren lngZeile, lngStart, 9
End If
Next lngZeile
' Spaltenbreite H:I anpassen
Columns("H:I").AutoFit
End Sub
Sub Ausfuehren(lngZ As Long, lngSt As Long, intSpalte As Integer)
' Zeilen einfügen in Abhängigkeit von der Anzahl an aufzuteilenden Werten
Rows(lngZ & ":" & lngSt).Insert
' Zeile kopieren und in die frei gewordenen Zeilen einfügen
Rows(lngSt + 1).Copy Rows(lngZ & ":" & lngSt)
' Spalte H oder I im betreffenden Bereich mit Zahlenformat formatieren
Cells(lngZ, intSpalte).Resize(UBound(varKontakt) + 1, 1).NumberFormat = "00000"
' Spalte H oder I im betreffenden Bereich die gesplitteten WErte eintragen
Cells(lngZ, intSpalte).Resize(UBound(varKontakt) + 1, 1) = Application.Transpose(varKontakt) _
End Sub

Beliebteste Forumthreads (12 Monate)

5 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

5
Beiträge zum Forumthread

Beiträge zu diesem Forumthread