Combine Multiple rows and delete duplicates in multiple columns

rahul_shokeen

New Member
Joined
Jun 13, 2022
Messages
3
Office Version
  1. 365
  2. 2021
Platform
  1. Windows
I want to find duplicates in Column A & Column K and combine rows from D to J. Currently, I am using Kutools to combine rows. I want to use VBA to summarize the data.
Kutools.jpg


Input
Input.jpg


Desired Output
Output.jpg



VBA Code:
Sub HSNTotal()
   Dim Cl As Range, Rng As Range
   Dim Txt As String
   
   With CreateObject("scripting.dictionary")
      For Each Cl In Range("A1", Range("A" & Rows.Count).End(xlUp))
         Txt = Cl.Value & Cl.Offset(, 10).Value
         If Not .Exists(Txt) Then
            .Add Txt, Cl.Offset(, 5)
         Else
            .Item(Txt).Value = .Item(Txt).Value + Cl.Offset(, 5).Value
            .Item(Txt).Value = Round(.Item(Txt).Value, 2)
            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

Dim r As Long
Dim LastRow As Long
LastRow = Cells(Rows.Count, "F").End(xlUp).Row
For r = LastRow To 1 Step -1
If Cells(r, "F") = 0 Then
Rows(r).Delete
End If
Next r
   
End Sub

The code is working perfectly for deleting duplicates in columns A & K. Also, It combines column F. But I don't know how to add other columns D, E, G, H, I, and J in the code to sum them. Please help.
Excel Link:
 

Excel Facts

What is the fastest way to copy a formula?
If A2:A50000 contain data. Enter a formula in B2. Select B2. Double-click the Fill Handle and Excel will shoot the formula down to B50000.

Alex Blakenburg

MrExcel MVP
Joined
Feb 23, 2021
Messages
5,129
Office Version
  1. 365
Platform
  1. Windows
See if this will work for you.
VBA Code:
Sub HSNTotal_mod()
    Dim srcSht As Worksheet, destSht As Worksheet
    Dim srcRng As Range, destRng As Range
    Dim srcArr As Variant, destArr()
    Dim srcDict As Object, dKey As String
    Dim i As Long, j As Long, destRow As Long
    
    Set srcSht = Worksheets("Input")
    Set destSht = Worksheets("Output")
    
    Set srcRng = srcSht.Range("A1").CurrentRegion
    srcArr = srcRng
    Set destRng = destSht.Range("A1")
    ReDim destArr(1 To UBound(srcArr, 1), 1 To UBound(srcArr, 2))
    Set srcDict = CreateObject("scripting.dictionary")
    
    For i = 1 To UBound(srcArr, 1)
        dKey = srcArr(i, 1) & "|" & srcArr(i, 11)
        If Not srcDict.exists(dKey) Then
            destRow = destRow + 1
            srcDict(dKey) = destRow
            For j = 1 To UBound(destArr, 2)
                If i > 1 And j >= 4 And j <= UBound(destArr, 2) - 1 Then
                    destArr(destRow, j) = srcArr(i, j) + 0
                Else
                    destArr(destRow, j) = srcArr(i, j)
                End If
            Next j
        Else
            For j = 4 To UBound(destArr, 2) - 1
                destArr(srcDict(dKey), j) = destArr(srcDict(dKey), j) + srcArr(i, j)
            Next j
        End If
    Next i
    
    destRng.Resize(destRow, UBound(destArr, 2)).Value = destArr

End Sub
 

rahul_shokeen

New Member
Joined
Jun 13, 2022
Messages
3
Office Version
  1. 365
  2. 2021
Platform
  1. Windows
Thanks! your code works like charm.

Alex Blakenburg

I want to overwrite the original worksheet instead of updating data in another worksheet.
Also, want to delete the row if the sum of column "E to J" = 0

 

Alex Blakenburg

MrExcel MVP
Joined
Feb 23, 2021
Messages
5,129
Office Version
  1. 365
Platform
  1. Windows
I left in the references to a Destination sheet and just pointed it at the original sheet but see if this works for you.
Make sure you have a backup of your original before running it, since it does overwrite the original sheet now.

VBA Code:
Sub HSNTotal_mod_reduced()

    Dim srcSht As Worksheet, destSht As Worksheet
    Dim srcRng As Range, destRng As Range
    Dim srcArr As Variant, destArr(), destArrReduced()
    Dim srcDict As Object, dKey As String
    Dim i As Long, j As Long, destRow As Long, destRowRed As Long
    
    Set srcSht = Worksheets("hsn")
    Set destSht = srcSht
    
    Set srcRng = srcSht.Range("A1").CurrentRegion
    srcArr = srcRng
    Set destRng = destSht.Range("A2")
    ReDim destArr(1 To UBound(srcArr, 1), 1 To UBound(srcArr, 2))
    Set srcDict = CreateObject("scripting.dictionary")
    
    For i = 1 To UBound(srcArr, 1)
        dKey = srcArr(i, 1) & "|" & srcArr(i, 11)
        If Not srcDict.exists(dKey) Then
            destRow = destRow + 1
            srcDict(dKey) = destRow
            For j = 1 To UBound(destArr, 2)
                If i > 1 And j >= 4 And j <= UBound(destArr, 2) - 1 Then
                    destArr(destRow, j) = srcArr(i, j) + 0
                Else
                    destArr(destRow, j) = srcArr(i, j)
                End If
            Next j
        Else
            For j = 4 To UBound(destArr, 2) - 1
                destArr(srcDict(dKey), j) = destArr(srcDict(dKey), j) + srcArr(i, j)
            Next j
        End If
    Next i
    
    'Eliminate zero value rows
    ReDim destArrReduced(1 To destRow, 1 To UBound(destArr, 2))
    Dim sumVal As Double
    destRowRed = 0
    For i = 2 To destRow
        sumVal = 0
        For j = 4 To UBound(destArr, 2) - 1
            sumVal = sumVal + destArr(i, j)
        Next j
                  
        If Round(sumVal, 2) <> 0 Then
            destRowRed = destRowRed + 1
            For j = 1 To UBound(destArr, 2)
                destArrReduced(destRowRed, j) = destArr(i, j)
            Next j
        End If
    Next i
       
    srcRng.Resize(srcRng.Rows.Count - 1).Offset(1).ClearContents
    destRng.Resize(destRowRed, UBound(destArrReduced, 2)).Value = destArrReduced

End Sub
 
Solution

rahul_shokeen

New Member
Joined
Jun 13, 2022
Messages
3
Office Version
  1. 365
  2. 2021
Platform
  1. Windows
I left in the references to a Destination sheet and just pointed it at the original sheet but see if this works for you.
Make sure you have a backup of your original before running it, since it does overwrite the original sheet now.

VBA Code:
Sub HSNTotal_mod_reduced()

    Dim srcSht As Worksheet, destSht As Worksheet
    Dim srcRng As Range, destRng As Range
    Dim srcArr As Variant, destArr(), destArrReduced()
    Dim srcDict As Object, dKey As String
    Dim i As Long, j As Long, destRow As Long, destRowRed As Long
   
    Set srcSht = Worksheets("hsn")
    Set destSht = srcSht
   
    Set srcRng = srcSht.Range("A1").CurrentRegion
    srcArr = srcRng
    Set destRng = destSht.Range("A2")
    ReDim destArr(1 To UBound(srcArr, 1), 1 To UBound(srcArr, 2))
    Set srcDict = CreateObject("scripting.dictionary")
   
    For i = 1 To UBound(srcArr, 1)
        dKey = srcArr(i, 1) & "|" & srcArr(i, 11)
        If Not srcDict.exists(dKey) Then
            destRow = destRow + 1
            srcDict(dKey) = destRow
            For j = 1 To UBound(destArr, 2)
                If i > 1 And j >= 4 And j <= UBound(destArr, 2) - 1 Then
                    destArr(destRow, j) = srcArr(i, j) + 0
                Else
                    destArr(destRow, j) = srcArr(i, j)
                End If
            Next j
        Else
            For j = 4 To UBound(destArr, 2) - 1
                destArr(srcDict(dKey), j) = destArr(srcDict(dKey), j) + srcArr(i, j)
            Next j
        End If
    Next i
   
    'Eliminate zero value rows
    ReDim destArrReduced(1 To destRow, 1 To UBound(destArr, 2))
    Dim sumVal As Double
    destRowRed = 0
    For i = 2 To destRow
        sumVal = 0
        For j = 4 To UBound(destArr, 2) - 1
            sumVal = sumVal + destArr(i, j)
        Next j
                 
        If Round(sumVal, 2) <> 0 Then
            destRowRed = destRowRed + 1
            For j = 1 To UBound(destArr, 2)
                destArrReduced(destRowRed, j) = destArr(i, j)
            Next j
        End If
    Next i
      
    srcRng.Resize(srcRng.Rows.Count - 1).Offset(1).ClearContents
    destRng.Resize(destRowRed, UBound(destArrReduced, 2)).Value = destArrReduced

End Sub
Thank you

Alex Blakenburg

it solved everything for me.
 

Forum statistics

Threads
1,176,393
Messages
5,902,810
Members
434,997
Latest member
bigolbearking

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