✔ Werte in Zeile

[jerry0110]

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.

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.

 

[Yaslaw]

Excel? Ich geh mal davon aus.

Dann könnte das etwa so aussehen

Public Sub extract()
    Dim ws As Worksheet:
    Dim subItems() As String:
    Dim rowNr As Long
    Dim subNr As Long
    Dim actRow As Range
    Dim actFld As Range
    
    Set ws = ActiveSheet
    'Von der letzten Zeile nach oben arbeiten, dann müssen wir nix mitrechnen
    For rowNr = xlsGetLastRow(ws) To 1 Step -1
    
        Set actRow = ws.Rows(rowNr)
        Set actFld = actRow.Cells(1, 1)
        'Die SubItems ermitteln. Splitten des Titelfeldes in ein Array
        subItems = Split(actFld.Value, ";")
        'Alle SubTitles durchiterieren
        For subNr = 0 To UBound(subItems)
            'Original kopieren
            actRow.Copy
            'Als neue Zeile einfügen
            actRow.Offset(subNr + 1, 0).Insert Shift:=xlDown
            'Titelfeld überschreiben
            actFld.Offset(subNr + 1, 0).Value = subItems(subNr)
        Next subNr
    Next rowNr
End Sub


'/**
' * Ermittelt die letzte gefüllte Zeile eines Worksheets
' * @param  Worksheet   Das Worksheetobjekt, das durchsucht werden soll
' * @return Long        Die Zeilennummer. Wenn das ganze Sheet leer ist, ist der Rückgabewert 0
' */
Public Function xlsGetLastRow(ByRef sheet As Object) As Long
    Const xlCellTypeLastCell = 11

    'Zur letzten initialisierten Zeile gehen
    xlsGetLastRow = sheet.Cells.SpecialCells(xlCellTypeLastCell).row
    
    'Von dort zurücksuchen bis zur Letzten zeile mit Inhalt
    Do While sheet.Application.WorksheetFunction.CountA(sheet.Rows(xlsGetLastRow)) = 0 And xlsGetLastRow > 1
        xlsGetLastRow = xlsGetLastRow - 1
    Loop
End Function

 

[jerry0110]

Hi,

wie nicht anders zu erwarten, wenn du Antwortest, funktioniert es.

Das einzige was er halt macht ist, dass er wenn nur ein Eintrag vorhanden ist das er den auch noch mal kopiert in eine neue Zeile. Und die Zeile wo die ganzen Einträge drin sind, bleibt als extra Zeile.

Im Grund müssten die, die nur einen Eintrag haben übersprungen werden und die die mehrere haben aufgeteilt und dann die ursprungszeile mit allen einträgen gelöscht werden.

Mit Duplikate löschen habe ich dann die Liste bereinigt.

 

[Yaslaw]

Oder du baust dir ein if ein

      If uBound(subItems > 0) Then       
          For subNr = 0 To UBound(subItems)
              ..
          Next subNr
      End If

 

[jerry0110]

Stimmt

Danke.. Nur du müsstest:

if uBound....

in

if UBound

ändern, weil sonst ein Fehler kommt.

 

[jerry0110]

Ich habe doch noch eine Frage. Wenn ich bei dem Code

For subNr = 0 To UBound(subItems)
            'Original kopieren
           actRow.Copy
            'Als neue Zeile einfügen
           actRow.Offset(subNr + 1, 0).Insert Shift:=xlDown
            'Titelfeld überschreiben
           actFld.Offset(subNr + 1, 0).Value = subItems(subNr)

noch ein

actRow.Delete

einfüge, damit die ausgewählte Zeile danach gelöscht wird.

So war der Plan, aber läuft nicht.
Ich bekomme immer einen Laufzeitfehler 424 angezeigt.

 

[Yaslaw]

Das läuft bei mir ohne Problem durch. Der delete darf natürlich erst nach der Kopier-Schleife sein.

Public Sub extract()
    Dim ws As Worksheet:
    Dim subItems() As String:
    Dim rowNr As Long
    Dim subNr As Long
    Dim actRow As Range
    Dim actFld As Range
   
    Set ws = ActiveSheet
    'Von der letzten Zeile nach oben arbeiten, dann müssen wir nix mitrechnen
   For rowNr = xlsGetLastRow(ws) To 1 Step -1
   
        Set actRow = ws.Rows(rowNr)
        Set actFld = actRow.Cells(1, 1)
        
        'Prüfen ob ein Wert in A# vorhanden ist
        If Not actFld.Value = Empty Then
            'Die SubItems ermitteln. Splitten des Titelfeldes in ein Array
            subItems = Split(actFld.Value, ";")
            'Alle SubTitles durchiterieren
            For subNr = 0 To UBound(subItems)
                'Original kopieren
                actRow.Copy
                'Als neue Zeile einfügen
                actRow.Offset(subNr + 1, 0).Insert Shift:=xlDown
                'Titelfeld überschreiben
                actFld.Offset(subNr + 1, 0).Value = subItems(subNr)
            Next subNr
            'Die aktuelle Zeile löschen
            actRow.Delete xlUp
        End If
    Next rowNr
End Sub

 

[jerry0110]

Genau daran lag es
Alles super.. Danke