jerry0110
Erfahrenes Mitglied
Hallo zusammen,
ich suche nach einem Code der im Grunde das gleiche macht wie dieser hier, nur nicht in eine Spalte sondern in eine Zeile:
Ausgangspunkt ist, dass ich in Spalte A mehrere Berufsgruppen habe die mit einem ";" getrennt sind. In Spalte B -> Z sind dann Werte wie Emailadresse, Ansprachpartner, etc.
Ziel ist es, dass ich wenn mehrere Werte in z. B. A1 sind die mit einem ";" getrennt sind, diese dann in neue da drunter erstellten Zeilen gepackt werden, mit den Werten der restlichen Spalten. Also dann von B1 -> Z1.
EDIT: Vielleicht müsste der Titel besser Spalte in Zeile heißen.
ich suche nach einem Code der im Grunde das gleiche macht wie dieser hier, nur nicht in eine Spalte sondern in eine Zeile:
Ausgangspunkt ist, dass ich in Spalte A mehrere Berufsgruppen habe die mit einem ";" getrennt sind. In Spalte B -> Z sind dann Werte wie Emailadresse, Ansprachpartner, etc.
Ziel ist es, dass ich wenn mehrere Werte in z. B. A1 sind die mit einem ";" getrennt sind, diese dann in neue da drunter erstellten Zeilen gepackt werden, mit den Werten der restlichen Spalten. Also dann von B1 -> Z1.
Code:
Private Sub BearbeitenRohdaten()
Dim ws As Worksheet: Set ws = Worksheets("Bearbeitet")
Dim maxParts As Long
Dim rowNr As Long
Dim parts() As String
Dim col As Range
Dim colNrDelta As Long
'Spalte auswählen
Set col = ws.Columns(Application.Match("FIRMENNAME", Rows(1), 0))
'Den Replace durchführen
col.Replace Chr(10), "|"
'Anzahl neuer Spalten ermitteln. Massgebend ist das Feld mit den meisten |
For rowNr = 2 To xlsGetLastRow(ws)
parts = Split(ws.Cells(rowNr, col.Column), "|")
If UBound(parts) + 1 > maxParts Then maxParts = UBound(parts) + 1
Next rowNr
'Spalten hinzufügen und Titel setzen
For colNrDelta = maxParts To 1 Step -1
ws.Columns(col.Column + 1).Insert xlShiftToRight
ws.Cells(1, col.Column + 1).Value = ws.Cells(1, col.Column).Value & "(" & colNrDelta & ")"
Next colNrDelta
'Neue Felder abfüllen
For rowNr = 2 To xlsGetLastRow(ws)
parts = Split(ws.Cells(rowNr, col.Column), "|")
For colNrDelta = 1 To UBound(parts) + 1
ws.Cells(rowNr, col.Column + colNrDelta).Value = parts(colNrDelta - 1)
Next colNrDelta
Next rowNr
Set col = Nothing
Set ws = Nothing
End Sub
EDIT: Vielleicht müsste der Titel besser Spalte in Zeile heißen.
Zuletzt bearbeitet: