VBA Code to delete duplicate values from a row and sum the corresponding column values in another sheet

[Jyotirmaya]

I have excel sheet in Sheet1 in Column ABC, I have data, there are more than 5000 rows. I want that in Sheet2 ABC Column the duplicates from column A is to be deleted, & B,C Columns value to be added. Only unique values to be there only in the Column A after deleting the duplicates. Please help me for the code.

 

[Logit]

& B,C Columns value to be added

Added to Sheet 2 ?

Those values added to columns B&C of Sheet 2 or to columns A&B of Sheet 2 ?

 

[Jyotirmaya]

Added to Sheet 2 ?

Those values added to columns B&C of Sheet 2 or to columns A&B of Sheet 2 ?

Sheet 2 is blank now, I want the result in Column A B C in sheet 2.

 

[Jyotirmaya]

Hello, Can anyone reply

 

[mumps]

Try:

Sub DeleteDups()
    Application.ScreenUpdating = False
    Dim v As Variant, i As Long, dic As Object, srcWS As Worksheet, desWS As Worksheet, lRow As Long, fnd As Range
    Set srcWS = Sheets("Sheet1")
    Set desWS = Sheets("Sheet2")
    Set dic = CreateObject("Scripting.Dictionary")
    With srcWS
        lRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
        v = .Range("A2:A" & lRow).Resize(, 3).Value
        For i = LBound(v) To UBound(v)
            If Not dic.exists(v(i, 1)) Then
                dic.Add v(i, 1), Nothing
                desWS.Cells(desWS.Rows.Count, 1).End(xlUp).Offset(1).Resize(, 3).Value = Array(v(i, 1), desWS.Range("B" & i + 1) + v(i, 2), desWS.Range("C" & i + 1) + v(i, 3))
            Else
                Set fnd = desWS.Range("A:A").Find(v(i, 1))
                desWS.Range("A" & fnd.Row).Resize(, 3).Value = Array(v(i, 1), desWS.Range("B" & fnd.Row) + v(i, 2), desWS.Range("C" & fnd.Row) + v(i, 3))
            End If
        Next i
    End With
    Application.ScreenUpdating = True
End Sub

 

[Jyotirmaya]

Try:

Sub DeleteDups()
    Application.ScreenUpdating = False
    Dim v As Variant, i As Long, dic As Object, srcWS As Worksheet, desWS As Worksheet, lRow As Long, fnd As Range
    Set srcWS = Sheets("Sheet1")
    Set desWS = Sheets("Sheet2")
    Set dic = CreateObject("Scripting.Dictionary")
    With srcWS
        lRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
        v = .Range("A2:A" & lRow).Resize(, 3).Value
        For i = LBound(v) To UBound(v)
            If Not dic.exists(v(i, 1)) Then
                dic.Add v(i, 1), Nothing
                desWS.Cells(desWS.Rows.Count, 1).End(xlUp).Offset(1).Resize(, 3).Value = Array(v(i, 1), desWS.Range("B" & i + 1) + v(i, 2), desWS.Range("C" & i + 1) + v(i, 3))
            Else
                Set fnd = desWS.Range("A:A").Find(v(i, 1))
                desWS.Range("A" & fnd.Row).Resize(, 3).Value = Array(v(i, 1), desWS.Range("B" & fnd.Row) + v(i, 2), desWS.Range("C" & fnd.Row) + v(i, 3))
            End If
        Next i
    End With
    Application.ScreenUpdating = True
End Sub

THANK YOU SO MUCH

 

[mumps]

You are very welcome.