Sum and remove duplicate rows

[Exceladd1ct]

Hi, i wrote a macro that will Sum and Delete duplicate rows. The code works fine, however it seems to me that i wrote to much code for a simple task.
Can you sugest a simpler approach please?

Thanks.

Option Explicit

Sub test()
    Dim lrow        As Long, k As Long, i As Long, q As Long
    Dim fullstr     As String, fullstr2 As String
    Dim arr         As Variant
    ReDim arr(0)
    'Get last row in column A
    lrow = Cells(Rows.Count, 1).End(xlUp).Row
    'First loop
    For k = 2 To lrow Step 1
        'Create a string from all columns to avoid multiple Ifs
        fullstr = Cells(k, 1) & Cells(k, 2) & Cells(k, 3)
        'Second loop
        For i = 2 To lrow Step 1
            'Create a string from all columns to avoid multiple Ifs
            fullstr2 = Cells(i, 1) & Cells(i, 2) & Cells(i, 3)
            'Make sure to only have combinations without repetitions
            If k <> i And k < i Then
                'Checking criterias
                If fullstr = fullstr2 And fullstr <> "" Then
                    MsgBox fullstr & " - " & Cells(k, 4) & vbCrLf & fullstr2 & " - " & Cells(i, 4)
                    Cells(k, 4).Value = (Cells(k, 4).Value + Cells(i, 4).Value)
                    arr(UBound(arr)) = i
                    ReDim Preserve arr(UBound(arr) + 1)
                    Range("A" & i).EntireRow.ClearContents
                End If
            End If
        Next
    Next
    'Loop to delete empty rows
    For q = UBound(arr) - 1 To LBound(arr) Step -1
        MsgBox arr(q)
        Range("A" & arr(q)).EntireRow.Delete
    Next
End Sub

 

[Fluff]

How about

Sub Exceladd1ct()
   Dim Cl As Range, Rng As Range
   Dim Txt As String
   
   With CreateObject("scripting.dictionary")
      For Each Cl In Range("A2", Range("A" & Rows.count).End(xlUp))
         Txt = Cl.Value & Cl.Offset(, 1).Value & Cl.Offset(, 2).Value
         If Not .exists(Txt) Then
            .Add Txt, Cl.Offset(, 3)
         Else
            .Item(Txt).Value = .Item(Txt).Value + Cl.Offset(, 3).Value
            If Rng Is Nothing Then Set Rng = Cl Else Set Rng = Union(Rng, Cl)
         End If
      Next Cl
   End With
   If Not Rng Is Nothing Then Rng.EntireRow.Delete
End Sub

 

[Exceladd1ct]

How about

Sub Exceladd1ct()
   Dim Cl As Range, Rng As Range
   Dim Txt As String
  
   With CreateObject("scripting.dictionary")
      For Each Cl In Range("A2", Range("A" & Rows.count).End(xlUp))
         Txt = Cl.Value & Cl.Offset(, 1).Value & Cl.Offset(, 2).Value
         If Not .exists(Txt) Then
            .Add Txt, Cl.Offset(, 3)
         Else
            .Item(Txt).Value = .Item(Txt).Value + Cl.Offset(, 3).Value
            If Rng Is Nothing Then Set Rng = Cl Else Set Rng = Union(Rng, Cl)
         End If
      Next Cl
   End With
   If Not Rng Is Nothing Then Rng.EntireRow.Delete
End Sub

Great, Scripting Dictionary. Thank you!

 

[Fluff]

You're welcome & thanks for the feedback.