Thread: Consolidate Repetitive Data

Hi All

I have a large set of Data that needs to be consolidated. Basically the data contains a large no of repetitive data and I need to consolidate them to analyze it further. Your assistance is much appreciated.

I have attached the spreadsheet with a sample data and the outcome that I would like to obtain. Hope it all makes sense.

Thanks

Tamil

You can achieve the same through SUBTOTALS.

As an after thought, i realised that sub totals wouldnt help you. I can provide you a small macro that will do your work.

However, i have a question. I plan on checking 1 row with the next one to see if its same and then sum the values in column F. Which are the fields that i should check for similarity? Is it A to E & G or is just 1 field sufficient?

Use this code. The output will appear in Sheet 2. I didnt find any headers, you can put them in Sheet1 row2 and in Sheet2 row1.

Option Explicit
Dim lrow As Long
Dim i As Long
Dim rsum As Variant

Sub consolidate_data()

With Worksheets("Sheet1")
    lrow = .Range("A" & Rows.Count).End(xlUp).Row
    For i = 3 To lrow
        If .Range("A" & i).Value = .Range("A" & i + 1).Value And .Range("B" & i).Value = .Range("B" & i + 1).Value And _
        .Range("C" & i).Value = .Range("C" & i + 1).Value And .Range("D" & i).Value = .Range("D" & i + 1).Value And _
        .Range("G" & i).Value = .Range("G" & i + 1).Value Then
            rsum = rsum + .Range("F" & i).Value
        ElseIf .Range("A" & i).Value <> .Range("A" & i + 1).Value And .Range("B" & i).Value <> .Range("B" & i + 1).Value And _
        .Range("C" & i).Value <> .Range("C" & i + 1).Value And .Range("D" & i).Value <> .Range("D" & i + 1).Value And _
        .Range("G" & i).Value <> .Range("G" & i + 1).Value Then
            rsum = rsum + .Range("F" & i).Value
            .Range("A" & i & ":E" & i).Copy Worksheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
            Worksheets("Sheet2").Range("F" & Rows.Count).End(xlUp).Offset(1, 0).Value = rsum
            .Range("G" & i).Copy Worksheets("Sheet2").Range("G" & Rows.Count).End(xlUp).Offset(1, 0)
            rsum = 0
        End If
    Next i
End With

End Sub

I can guide you along. Press Alt+F11 on your file. It will open a code window. On the left hand side, you will see Microsoft Excel Objects. Right click on it and select Insert-> Module. Copy the above code into it. Go back to your main page. Go to View-> Macros and select the macro that is visible there.
Run it.

Hey,

You had asked to include column G, so i did. Find the revised code as below

Option Explicit
Dim lrow As Long
Dim i As Long
Dim rsum As Variant

Sub consolidate_data()

With Worksheets("Sheet1")
    lrow = .Range("A" & Rows.Count).End(xlUp).Row
    For i = 3 To lrow
        If .Range("A" & i).Value = .Range("A" & i + 1).Value And .Range("B" & i).Value = .Range("B" & i + 1).Value And _
        .Range("C" & i).Value = .Range("C" & i + 1).Value And .Range("D" & i).Value = .Range("D" & i + 1).Value Then
            rsum = rsum + .Range("F" & i).Value
        ElseIf .Range("A" & i).Value <> .Range("A" & i + 1).Value And .Range("B" & i).Value <> .Range("B" & i + 1).Value And _
        .Range("C" & i).Value <> .Range("C" & i + 1).Value And .Range("D" & i).Value <> .Range("D" & i + 1).Value Then
            rsum = rsum + .Range("F" & i).Value
            .Range("A" & i & ":E" & i).Copy Worksheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
            Worksheets("Sheet2").Range("F" & Rows.Count).End(xlUp).Offset(1, 0).Value = rsum
            .Range("G" & i).Copy Worksheets("Sheet2").Range("G" & Rows.Count).End(xlUp).Offset(1, 0)
            rsum = 0
        End If
    Next i
End With

End Sub

Hey no, its never a waste of time. What do you mean the nos are not there yet? Are you getting any error?

Try this code -

Option Explicit

Dim lrow As Long
Dim i As Long
Dim rsum As Variant

Sub consolidate_data()

With Worksheets("Sheet1")
    lrow = .Range("A" & Rows.Count).End(xlUp).Row
    For i = 3 To lrow
        If .Range("B" & i).Value = .Range("B" & i + 1).Value Then
            rsum = rsum + .Range("D" & i).Value
        ElseIf .Range("B" & i).Value <> .Range("B" & i + 1).Value Then
            rsum = rsum + .Range("D" & i).Value
            .Range("A" & i & ":C" & i).Copy Worksheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
            Worksheets("Sheet2").Range("D" & Rows.Count).End(xlUp).Offset(1, 0).Value = rsum
            rsum = 0
        End If
    Next i
End With

End Sub