Объединение нескольких строк Excel на основе одинакового содержимого с последующим увеличением столбца в VBA

Question

Я пытаюсь настроить подпрограмму VBA, которая будет проверять все строки на рабочем листе, а затем объединит две одинаковые строки, а затем это увеличит столбец "QTY".

Ниже приведен пример того, чего я хочу достичь.

---

До:

---

После:

---

Я попытался применить несколько решений, которые я нашел в Superuser и в различных местах в Интернете, но, к сожалению, к этому ничего не относится, и мое ограниченное понимание VBA в Excel мешает мне разобраться с этим вопросом.

Answer 1

Вставьте этот код в модуль, прежде чем использовать его, измените переменную qtycolumn на номер столбца, в котором у вас есть заголовок QTY :

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