Sum and remove duplicate rows

Exceladd1ct

Board Regular
Joined
Feb 10, 2019
Messages
64
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.

VBA Code:
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
 

Attachments

  • 2020-12-28_14h16_37.png
    2020-12-28_14h16_37.png
    13.5 KB · Views: 12
  • 2020-12-28_14h16_49.png
    2020-12-28_14h16_49.png
    9.2 KB · Views: 13

Some videos you may like

Excel Facts

Remove leading & trailing spaces
Save as CSV to remove all leading and trailing spaces. It is faster than using TRIM().

Fluff

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
53,020
Office Version
  1. 365
Platform
  1. Windows
How about
VBA Code:
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
 
Solution

Exceladd1ct

Board Regular
Joined
Feb 10, 2019
Messages
64
How about
VBA Code:
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

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
53,020
Office Version
  1. 365
Platform
  1. Windows
You're welcome & thanks for the feedback.
 

Watch MrExcel Video

Forum statistics

Threads
1,122,745
Messages
5,597,887
Members
414,185
Latest member
tarun19954

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top