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

Question

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

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

---

До:

---

После:

---

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

Answer 1

Вставьте этот код в модуль, перед его использованием измените переменнуюqtycolumnк номеру столбца, где у вас есть вашКОЛ-ВОзаголовок:

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