VBA code to reduce total number of rows

[Wafee]

I have a excel sheet with around 5lakh rows and i want to reduce number of rows by cumilating the data so that i can add more.
below is the sample data (Couldn't share original data due to privacy reasons). Data should be combined based on Columns B,D,E,G.

If data present in B,D,E,F columns is same the code has to sum the values in G column and make it in to single row of data as shown in the next table.

A	B	C	D	E	F	G
City Code	City Name	Pincode	Date	Type	Description	Total
1	NewYork	32	1-Jan-20	SA	on	40
1	NewYork	32	1-Jan-20	SA	on	40
1	NewYork	32	1-Jan-20	NA	off	20
2	Sydney	44	20-Jan-20	NA	off	40
2	Sydney	44	20-Jan-20	NA	off	40
3	Delhi	94	20-Jan-20	SA	on	20
3	Delhi	94	20-Jan-20	SA	on	20
3	Delhi	94	20-Jan-20	SA	on	40

Out put expected is below.

City Code	City Name	Pincode	Date	Type	Description	Total
1	NewYork	32	1-Jan-20	SA	on	80
1	NewYork	32	1-Jan-20	NA	off	20
2	Sydney	44	20-Jan-20	NA	off	80
3	Delhi	94	20-Jan-20	SA	on	80

 

[Michael M]

Try....as long as the data is sorted

Sub MM1()
Dim lr As Long, r As Long
lr = Cells(Rows.Count, "A").End(xlUp).Row
For r = lr To 2 Step -1
    If Cells(r, 2) = Cells(r - 1, 2) And Cells(r, 4) = Cells(r - 1, 4) And Cells(r, 5) = Cells(r - 1, 5) And Cells(r, 6) = Cells(r - 1, 6) Then
        Cells(r - 1, 7) = Cells(r, 7) + Cells(r - 1, 7)
        Rows(r).Delete
    End If
Next r
End Sub

 

[Wafee]

Hi M

Try....as long as the data is sorted

Sub MM1()
Dim lr As Long, r As Long
lr = Cells(Rows.Count, "A").End(xlUp).Row
For r = lr To 2 Step -1
    If Cells(r, 2) = Cells(r - 1, 2) And Cells(r, 4) = Cells(r - 1, 4) And Cells(r, 5) = Cells(r - 1, 5) And Cells(r, 6) = Cells(r - 1, 6) Then
        Cells(r - 1, 7) = Cells(r, 7) + Cells(r - 1, 7)
        Rows(r).Delete
    End If
Next r
End Sub

Hi Michael,

Its taking more time as there are aroung 500k lines. Can you help me with a code that gives result in to a new sheet leaving the source as it is.
Consider workbook name is "wk" and source is in the sheet "Source".

 

[Michael M]

Try

Sub MM1()
Dim lr As Long, r As Long, sh As Worksheet
Application.ScreenUpdating = False
lr = Cells(Rows.Count, "A").End(xlUp).Row
Sheets.Add
ActiveSheet.Name = "NewSheet"
Set sh  = Sheets("NewSheet")
Sheets("Source").UsedRange.Copy sh.Range("A1")
With sh
For r = lr To 2 Step -1
    If Cells(r, 2) = Cells(r - 1, 2) And Cells(r, 4) = Cells(r - 1, 4) And Cells(r, 5) = Cells(r - 1, 5) And Cells(r, 6) = Cells(r - 1, 6) Then
        Cells(r - 1, 7) = Cells(r, 7) + Cells(r - 1, 7)
        Rows(r).Delete
    End If
Next r
End With
Application.ScreenUpdating = True
End Sub

 

[Wafee]

Try

Sub MM1()
Dim lr As Long, r As Long, sh As Worksheet
Application.ScreenUpdating = False
lr = Cells(Rows.Count, "A").End(xlUp).Row
Sheets.Add
ActiveSheet.Name = "NewSheet"
Set sh  = Sheets("NewSheet")
Sheets("Source").UsedRange.Copy sh.Range("A1")
With sh
For r = lr To 2 Step -1
    If Cells(r, 2) = Cells(r - 1, 2) And Cells(r, 4) = Cells(r - 1, 4) And Cells(r, 5) = Cells(r - 1, 5) And Cells(r, 6) = Cells(r - 1, 6) Then
        Cells(r - 1, 7) = Cells(r, 7) + Cells(r - 1, 7)
        Rows(r).Delete
    End If
Next r
End With
Application.ScreenUpdating = True
End Sub

It's taking hours to finish the process mate. Is they any other way to do this?(data might is sorted this time but i might not get sorted data everytime)