Combinando várias linhas do Excel com base em conteúdos semelhantes, em seguida, incrementando uma coluna no VBA

Question

Eu estou tentando configurar uma rotina VBA que irá verificar todas as linhas de uma planilha e, em seguida, combinar duas linhas que são idênticas, em seguida, uma vez que isso incrementa a coluna "QTY".

Abaixo está um exemplo de antes e depois do que estou procurando alcançar.

Antes:

Depois:

Eu tentei aplicar algumas soluções que encontrei em Superusuários e vários lugares da Internet, mas infelizmente nada se aplica diretamente a isso e meu conhecimento limitado do VBA no Excel está me impedindo de contornar esse problema.

    

Answer 1

Insira este código em um módulo, antes de usá-lo, altere a variável qtycolumn para o número da coluna em que você tem seu título 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