Wenn Wert doppelt, dann Zeile darunter einfügen

Hallo alle zusammen!

Ich habe eine Exceldatei mit 5 Spalten. In Spalte A befinden sich Kundennummern, in Spalte B die Produktbezeichnung, in Spalte C die Farbinfo und in Spalte D befinden sich Größenangaben. Spalte E ist zunächst leer.

Folgendes soll passieren: Sobald das Skript eine Wiederholung der Artikelnummer in Spalte A erkennt, soll direkt darunter eine neue Zeile mit dem ersten Teil der Artikelnummer und den Inhalt aus Spalte Name einfügen.

Hier findet ihr meine Arbeitsdatei mit Beispiel wie das Ergebnis aussehen soll: http://www.herber.de/bbs/user/94905.xlsx

Wird eine Artikelnummer nur einmal gefunden, passiert nichts weiter und die Zeile bzw. Artikelnummer wird unverändert übersprungen.
Hat jemand so etwas umgesetzt und hat vielleicht ein Praxisbeispiel für mich?

Ich bin über jeden Tipp dankbar.

Wünsche allen ein erholsames Wochenende!
Der Tommy

Bitte markiere auch die Kommentare, die zur Lösung des Beitrags beigetragen haben

Content-ID: 259424

Url: https://administrator.de/contentid/259424

Ausgedruckt am: 22.11.2024 um 21:11 Uhr

12 Kommentare

Neuester Kommentar

Lasse bitte den Unsinn mit sinnfreien Doppelposts hier im Forum ! Das ist nicht gern gesehen und beschleunigt keineswegs die Lösung ! Mal ganz abgesehen das es eines Philosphens (denn philósophos="Freund der Weisheit“) sicher unwürdig, da unweise, ist !

Einen kann man immer löschen oder von der Freigabe ausnehmen...auch nachträglich noch !

Danke für den Hinweis. Leider finde ich in der FAQ dazu nur folgendes:
So kannst Du Deinen Beitrag, der noch nicht beantwortet wurde, löschen:

Unter deinem Profil die Beitragsart und den Beitrag wählen.
Ganz rechts in dieser Zeile hinter dem betreffenden Beitrag erscheint ein X-Icon (ist das Icon nicht vorhanden, kannst Du den Beitrag nicht mehr löschen).
Alternativ: Auf den Beitrag (vielleicht möchtest du ihn ja vorher nochmal lesen, um dir ganz sicher zu sein) und unter dem Text auf Beitrag löschen klicken (auch mittels der rechten Navigation möglich).
durch Anklicken des Lösch-Icons (X) lässt sich der Beitrag nach einer Sicherheitsabfrage löschen.

Auch der zweite Beitrag ohne Kommentar lässt sich nicht löschen, da kein X-Icon vorhanden ist.

Über einen eintsprechenden Hinweis würde ich mich freuen.

LG
Tommy

Moin,
ganz einfach: Weil ich wohl schneller war wie du. Ich habe den Beitrag in den Papierkorb gelegt und gesperrt.
Nun zurück zum Thema...

Gruß,
Dani (Moderator)

Hallo Tommy,

Sub InsertRowAfterDuplicate()
    Dim ws As Worksheet, cell As Range, boolDouble As Boolean, arrSKU as Variant, arrPrevSKU as Variant
    Set ws = ActiveSheet
    boolDouble = False
    With ws
        Set cell = .Range("A2")  
        While cell.Value <> ""  
            arrSKU = Split(cell.Value, "-", -1, vbTextCompare)  
            arrPrevSKU = Split(cell.Offset(-1, 0).Value, "-", -1, vbTextCompare)  
            If arrPrevSKU(0) = arrSKU(0) Then
                boolDouble = True
            Else
                If boolDouble Then
                    cell.EntireRow.Insert
                    cell.Offset(-1, 0).Value = arrPrevSKU(0)
                    cell.Offset(-1, 1) = cell.Offset(-2, 1).Value
                    cell.Offset(-1, 4) = "color,size"  
                End If
                boolDouble = False
            End If
            Set cell = cell.Offset(1, 0)
        Wend
        If boolDouble Then
            cell.EntireRow.Insert
            cell.Offset(-1, 0).Value = arrPrevSKU(0)
            cell.Offset(-1, 1) = cell.Offset(-2, 1).Value
            cell.Offset(-1, 4) = "color,size"  
        End If
    End With
End Sub

Grüße Uwe

Hallo Uwe,

vielen Dank für deine schnelle Hilfe!

Mein Ziel war es, auf eigener Faust die Lösung auf meine Datei herzuleiten. Leider komme ich doch nicht so einfach damit zurecht.
Ich habe hier einen Link mit meiner echten Arbeitsdatei. Es müssen einfach nur einige weitere Zeilen mit runter kopiert werden.
Hier die Datei zum Download, auch mit einem Beispiel wie das Ergebnis aussehen soll:
http://www.herber.de/bbs/user/94912.xlsx

Wenn es zu viel Arbeit bereitet, bin ich gerne auch über Paypal einen Obolus dafür zu leisten. Dein Ergebnis würde ich aber im Interesse aller anderen User hier veröffentlichen.

Best wishes
Tommy

Hab das noch extra etwas für dich verständlicher umgebaut, mit Kommentaren versehen und an dein neues Sheet angepasst:

Sub InsertRowAfterDuplicate()
    Dim cell As Range, currSKU As String, prevSKU As String, insertRow As Boolean, newRow As Range
    Application.ScreenUpdating = False
    prevSKU = ""  
    With ActiveSheet
        'Anfangszelle des Datenbereichs  
        Set cell = .Range("A3")  
        'So lange weitermachen bis Spalte A leer ist  
        While cell.Value <> ""  
            'sku der aktuellen Zelle  
            currSKU = Split(cell.Value, "-", -1, vbTextCompare)(0)  
            'Vergleiche aktuelle sku mit der vorherigen  
            If currSKU = prevSKU Then
                'wenn nächste Zelle nicht leer ist  
                If cell.Offset(1, 0).Value <> "" Then  
                    ' Wenn die nächste Zelle unterschiedlich zur aktuellen ist ...  
                    If Split(cell.Offset(1, 0).Value, "-", -1, vbTextCompare)(0) <> currSKU Then  
                        insertRow = True
                    End If
                Else    'Zelle leer = letzte Zelle  
                    insertRow = True
                End If
            End If
            If insertRow Then
                'ganze Zeile kopieren und darunter einfügen  
                cell.EntireRow.Copy
                cell.Offset(1, 0).Insert
                ' Anpasungen in den Spalten der neuen Zeile vornehmen  
                With cell.Offset(1, 0)
                    .Cells(1, 1).Value = currSKU
                    .Cells(1, 6).Value = 1
                    .Cells(1, 9).Value = "Deaktiviert"  
                    .Cells(1, 10).Value = ""  
                    .Cells(1, 11).Value = ""  
                    .Cells(1, 18).Value = "configurable"  
                    .Cells(1, 29).Value = "Einzeln nicht sichtbar"  
                    .Cells(1, 53).Value = "configurable"  
                    .Cells(1, 81).Value = ""  
                    .Cells(1, 82).Value = ""  
                    .Cells(1, 83).Value = "color,size"  
                End With
                'Zeiger für nächste Zelle um zwei nach unten verschieben  
                Set cell = cell.Offset(2, 0)
            Else
                'Zeiger für nächste Zelle um eins nach unten verschieben  
                Set cell = cell.Offset(1, 0)
            End If
            
            prevSKU = currSKU
            insertRow = False
        Wend
    End With
    Application.ScreenUpdating = True
    Application.CutCopyMode = False
    MsgBox "Fertig"  
End Sub

Wenn es zu viel Arbeit bereitet, bin ich gerne auch über Paypal einen Obolus dafür zu leisten

Die Spende nehme ich hier dankend entgegen: Spenden

Grüße Uwe

Hallo Uwe,

meine Spende ist raus!

Nochmal vielen Dank für die super Leistung!

In der Praxis hat sich nun gezeigt, dass das Skript an zwei Stellen noch erweitert werden muss:

1. Alle einmaligen Artikelnummern müssen an das Ende der Tabelle verschoben werden.
2. Bei Artikelnummern die mehrfach vorhanden sind, wird die Zelle Price auf den Wert "0.00" gesetzt. Die letzte Zeile mit der gleichen Artikelnummer (durch das Script hinzugefügt) bleibt jedoch unverändert.

Ein Beispieldokument mit deinem Skript findest du hier, die Korrekturen habe ich farblich angepasst:
https://www.wetransfer.com/downloads/1d593ccba513f1a0ad6a5dad03e31c3d201 ...

Ich wäre dir sehr dankbar, wenn du mir das nochmal anpassen kannst.

Einen guten Start in die neue Woche!

LG
Tommy

Hallo Tommy,

meine Spende ist raus! Nochmal vielen Dank für die super Leistung!

Ich bedanke mich herzlich

In der Praxis hat sich nun gezeigt, dass das Skript an zwei Stellen noch erweitert werden muss:

Ist das nicht immer so

Ich wäre dir sehr dankbar, wenn du mir das nochmal anpassen kannst.

guckst du hier

Sub InsertRowAfterDuplicate()
    Dim cell As Range, currSKU As String, prevSKU As String, insertRow As Boolean, newRow As Range, strPrice As Variant, rngSingleRows As Range, row As Range
    Application.ScreenUpdating = False
    prevSKU = ""  
    With ActiveSheet
        'Anfangszelle des Datenbereichs  
        Set cell = .Range("A2")  
        'So lange weitermachen bis Spalte A leer ist  
        While cell.Value <> ""  
            'sku der aktuellen Zelle  
            currSKU = Split(cell.Value, "-", -1, vbTextCompare)(0)  
            'Vergleiche aktuelle sku mit der vorherigen  
            If currSKU = prevSKU Then
                'aktuellen Preis speichern  
                strPrice = cell.Offset(0, 2).Value
                'Werte der Preiszellen setzen  
                cell.Offset(-1, 2).Value = "0.00"  
                cell.Offset(0, 2).Value = "0.00"  
                
                'wenn nächste Zelle nicht leer ist  
                If cell.Offset(1, 0).Value <> "" Then  
                    ' Wenn die nächste Zelle unterschiedlich zur aktuellen ist ...  
                    If Split(cell.Offset(1, 0).Value, "-", -1, vbTextCompare)(0) <> currSKU Then  
                        insertRow = True
                    End If
                Else    'Zelle leer = letzte Zelle  
                    insertRow = True
                End If
            End If
            If insertRow Then
                'ganze Zeile kopieren und darunter einfügen  
                cell.EntireRow.Copy
                cell.Offset(1, 0).Insert
                ' Anpasungen in den Spalten der neuen Zeile vornehmen  
                With cell.Offset(1, 0)
                    .Cells(1, 1).Value = currSKU
                    .Cells(1, 3).Value = strPrice
                    .Cells(1, 6).Value = 1
                    .Cells(1, 9).Value = "Deaktiviert"  
                    .Cells(1, 10).Value = ""  
                    .Cells(1, 11).Value = ""  
                    .Cells(1, 18).Value = "configurable"  
                    .Cells(1, 29).Value = "Einzeln nicht sichtbar"  
                    .Cells(1, 53).Value = "configurable"  
                    .Cells(1, 81).Value = ""  
                    .Cells(1, 82).Value = ""  
                    .Cells(1, 83).Value = "size,color"  
                    .Cells(1, 95).Value = ""  
                End With
                'Zeiger für nächste Zelle um zwei nach unten verschieben  
                Set cell = cell.Offset(2, 0)
            Else
                ' Wenn die nächste Zelle unterschiedlich zur aktuellen ist, ist es eine Einzelzeile  
                ' In diesem Fall speichere die Zeile zusammen mit den anderen Einzelzeilen in einer Range-Variablen  
                ' um sie dann zum Schluss ans Ende zu verschieben  
                If cell.Offset(1, 0).Value <> "" Then  
                    If Split(cell.Offset(1, 0).Value, "-", -1, vbTextCompare)(0) <> currSKU Then  
                        If Not rngSingleRows Is Nothing Then
                            Set rngSingleRows = Union(rngSingleRows, cell.EntireRow)
                        Else
                            Set rngSingleRows = cell.EntireRow
                        End If
                    End If
                End If
                'Zeiger für nächste Zelle um eins nach unten verschieben  
                Set cell = cell.Offset(1, 0)
            End If
            
            prevSKU = currSKU
            insertRow = False
        Wend
        'Einzelzellen am Ende einfügen  
        If Not rngSingleRows Is Nothing Then
            For Each row In rngSingleRows.Rows
                row.Copy
                cell.Insert
            Next
            rngSingleRows.Delete
        End If
    End With
    Application.ScreenUpdating = True
    Application.CutCopyMode = False
    MsgBox "Fertig"  
End Sub

Einen guten Start in die neue Woche!

Ebenso.

Grüße Uwe

Hallo Uwe,

ich habe nun dein Script in meine Datei eingefügt und die Tabelle mit echten Artikelnummern gefüllt.
Je nach Artikelnummern, erhalte ich eine Fehlermeldung wenn ich das Script ausführe. Sheet1 und Sheet2 zeigen mir deshalb unterschiedliche Fehlermeldungen

Den Link findest zu der Datei mit beiden Sheets bzw. Fehler findest du hier: http://we.tl/UPQuEaRaOc

Hast du eine Ahnung woran das liegt oder kann mir jemand dabei weiterhelfen?

Gute Nacht!

Tommy