Problema com o Excel VBA Script (Link para thread na mensagem)

Question

Estou trabalhando em escrever um script VBA para mesclar linhas se a ID corresponder e, em seguida, somar as informações em alguns campos e, finalmente, excluir a linha inferior para que eu tenha apenas uma entrada por ID.

Um recorte de tela dos dados com os quais estou trabalhando. As linhas 13 e 14 são um exemplo daquelas que precisam ser combinadas.

Exemplo de captura de dados

Eu baseei meu script fora da resposta de Raystafarian (última revisão) no Q & A abaixo:

Como combinar valores de várias linhas em uma única linha no Excel?

Meu script:

Sub mergeSumDelete()
Dim lastRow As Long
Dim myCell As Range

'lastRow = Cells(Rows.Count, "A").End(x1Up).Row

'Alternate way of trying to find the last row since I was having issues with the above
lastRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row

For Each myCell In Range(Cells("A2"), Cells(lastRow, 1))
    If (myCell = myCell.Offset(1)) And (myCell.Offset(0, 1) = myCell.Offset(1, 1)) Then
        'Add up the data from the matching cells and put it in the top cell
        myCell.Offset(0, 2) = myCell.Offset(0, 2) + myCell.Offset(1, 2)
        myCell.Offset(0, 3) = myCell.Offset(0, 3) + myCell.Offset(1, 3)
        myCell.Offset(0, 4) = myCell.Offset(0, 4) + myCell.Offset(1, 4)

        'Delete the bottom row after data is merged
        myCell.Offset(1).EntireRow.Delete
    End If
Next
End Sub

Aqui estão meus problemas que estou tendo.

1. Para a linha que está atribuindo lastRow um valor, estou recebendo um erro Runtime 1004. Não tenho certeza do que está acontecendo aqui. Eu tentei fazer isso de uma maneira diferente e depois encontrei outro erro ...

2. Eu encontrei uma maneira alternativa de atribuir ao lastRow um valor que parecia funcionar (ou não joguei um erro pelo menos ..) Agora recebo um erro com a instrução For each, um erro de runtime 5 (Invalid chamada de procedimento ou argumento).

Answer 1

Consegui encontrar uma solução / escrever um script melhor.

• Dimensiona a seleção com base nas necessidades dos meus objetivos
• Passa por uma seleção e tenta encontrar linhas com valores duplicados nas colunas A. (No meu caso, estes eram ID's de veículos)
• Se encontrar uma correspondência, ela soma os valores de B, C, D com os valores B, C, D da linha de ID correspondente abaixo
• Exclua a linha duplicada (linha abaixo da linha atual)
• Itera esse loop 3 vezes, caso haja até 4 duplicatas (meus dados permitiram isso; tentei uma solução dinâmica, mas não consegui. Dicas?)
• Redimensiona a seleção para remover linhas externas de valores zero

Qualquer comentário é bem-vindo, especialmente como torná-lo dinâmico para um número desconhecido de duplicatas.

Sub dataClean()
'Calls the below subs

Call compareSumDelete_v3
Call deleteZeroRows

End Sub

Sub compareSumDelete_v3()

'OPTIMIZATIONS ---------------------------------------------------------
With Application
    .ScreenUpdating = False
'END OPTIMIZATIONS -----------------------------------------------------

'DYNAMICALLY SELECTING THE RANGE TO WORK WITH --------------------------
    Dim sht As Worksheet
    Dim lastRow As Long
    Dim lastColumn As Long
    Dim startCell As Range

    Set sht = ActiveWorkbook.ActiveSheet
    Set startCell = Range("A2")

    'Refresh UsedRange
    ActiveWorkbook.ActiveSheet.UsedRange

    'Find Last Row
    lastRow = sht.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row

    'Select Range
    sht.Range("A2:D" & lastRow - 3).Select
'END OF SELECTING THE RANGE ---------------------------------------------

'COMPARING "A" CELL VALUES, SUMMING IF MATCH, DELETING OLD ENTRY --------
    Dim i As Long
    Dim j As Integer

    'Loop through three times in case there are up to 4 duplicate entries, will combine all 4 with 3 iterations
    For j = 1 To 3
        For i = 1 To Selection.Rows.Count Step 1
            If Selection.Rows(i).Columns("A") = Selection.Rows(i + 1).Columns("A") Then
                Selection.Rows(i).Columns("B") = Selection.Rows(i).Columns("B") + Selection.Rows(i + 1).Columns("B")
                Selection.Rows(i).Columns("C") = Selection.Rows(i).Columns("C") + Selection.Rows(i + 1).Columns("C")
                Selection.Rows(i).Columns("D") = Selection.Rows(i).Columns("D") + Selection.Rows(i + 1).Columns("D")

                Selection.Rows(i + 1).EntireRow.Delete

            End If
        Next i
    Next j
'END COMPARING/SUMMING/DELETING -----------------------------------------

End With

End Sub

Sub deleteZeroRows()

With Application
    .ScreenUpdating = False
    .Calculation = x1calculationmanual

'DYNAMICALLY SELECTING THE RANGE TO WORK WITH --------------------------
    Dim sht As Worksheet
    Dim lastRow As Long
    Dim lastColumn As Long
    Dim startCell As Range

    Set sht = ActiveWorkbook.ActiveSheet
    Set startCell = Range("B2")

    'Refresh UsedRange
    ActiveWorkbook.ActiveSheet.UsedRange

    'Find Last Row
    lastRow = sht.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row

    'Select Range
    sht.Range("B2:B" & lastRow).Select
'END OF SELECTING THE RANGE ---------------------------------------------

    Dim i As Long

    For i = Selection.Rows.Count To 1 Step -1
        If Selection.Rows(i) = 0 Then
            Selection.Rows(i).EntireRow.Delete
        End If
    Next i

End With
End Sub