Kombinieren mehrerer Excel-Zeilen basierend auf ähnlichem Inhalt und anschließendes Erhöhen einer Spalte in VBA

Question

Ich versuche, eine VBA-Routine einzurichten, die alle Zeilen eines Arbeitsblatts prüft, dann zwei identische Zeilen kombiniert und anschließend die Spalte „QTY“ erhöht.

Unten sehen Sie ein Vorher-Nachher-Beispiel dessen, was ich erreichen möchte.

---

Vor:

---

Nach:

---

Ich habe versucht, einige Lösungen anzuwenden, die ich bei Superuser und an verschiedenen Stellen im Internet gefunden habe, aber leider ist nichts davon direkt darauf anwendbar und meine begrenzten Kenntnisse von VBA in Excel hindern mich daran, in dieser Angelegenheit weiterzukommen.

Answer 1

Fügen Sie diesen Code in ein Modul ein und ändern Sie vor der Verwendung die VariableMengenspaltezur Nummer der Spalte, in der Sie IhreMengeTitel:

Sub customgroup()
    Dim a As Application
    Dim wkb As Workbook
    Dim wks As Worksheet
    Dim DataRange As Range
    Set a = Application
    Set wkb = ThisWorkbook
    Set wks = wkb.Sheets(1)
    wks.Application.ScreenUpdating = False
    qtycolumn = 4 'this have to be changed to the QTY column
    reviewing = True
    visitrow = 1
    While reviewing = True
        visitrow = visitrow + 1
        If wks.Cells(visitrow, 1) = "" Then
            reviewing = False
        End If
        If wks.Cells(visitrow, qtycolumn) <> 0 Then
            countitems = 1
            visitrow2 = visitrow + 1
            reviewing2 = reviewing
            While reviewing2 = True
                If wks.Cells(visitrow2, 1) = "" Then
                    reviewing2 = False
                End If
                If wks.Cells(visitrow2, qtycolumn) <> 0 Then
                    compareranges = Join(a.Transpose(a.Transpose(wks.Rows(visitrow).Value)), Chr(0)) = Join(a.Transpose(a.Transpose(wks.Rows(visitrow2).Value)), Chr(0))
                    If compareranges = True Then
                        countitems = countitems + wks.Cells(visitrow2, qtycolumn)
                        wks.Cells(visitrow2, qtycolumn) = 0
                    End If
                End If
                visitrow2 = visitrow2 + 1
            Wend
            wks.Cells(visitrow, qtycolumn) = countitems
        End If
    Wend
    visitrow = visitrow - 1
    LastColumn = wks.Range("A1").CurrentRegion.Columns.Count
    Set DataRange = Range(Cells(1, 1), Cells(visitrow, LastColumn))
    lettercolumn = Split(Cells(, qtycolumn).Address, "$")(1)
    DataRange.Sort key1:=Range(lettercolumn & ":" & lettercolumn), order1:=xlDescending, Header:=xlYes
    For i = visitrow To 2 Step -1
        filterqty = wks.Cells(i, qtycolumn)
        If filterqty = 0 Then
            wks.Rows(i).Delete
        End If
    Next i
   wks.Application.ScreenUpdating = True
End Sub