Combine Multiple rows and delete duplicates in multiple columns

[rahul_shokeen]

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.

Input

Desired Output

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:

HSN Merge.xlsm

drive.google.com

 

[Alex Blakenburg]

See if this will work for you.

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]

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

HSN Merge-2.xlsm

drive.google.com

 

[Alex Blakenburg]

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.

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

 

[rahul_shokeen]

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.

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.

 

[Alex Blakenburg]

You're welcome. Glad I could help.