Automate using CONSOLIDATE

[RIZVI]

Dear Friends,

Please find attached a SAMPLE SHEET.

What I require is that the data in SHEET1 is consolidated, numbers added and appear as per data in RESULTS.
But SHEET1 should consist the RESULTS sheet (the RESULTS should appear in the same SHEET1)
Maybe a copy/paste option should be considered. Copy/paste about 2 rows below the last row, delete from row 4 to last row & copy/paste the RESULT in cell A4 (as appearing in RESULTS sheet)

The first row, in sheet1 & RESULTS, are always cell A4.
the numbers appearing under SHEET1 in columns F, I & L has to be added and appear in the RESULTS.

However, the data, including blank rows can vary, from may be 20 to about 1000 rows or so.
Presume that the last row has to be identified and work out the VBA

Appreciate your assistance and thank you for same.

Thanks and with best wishes
Rizvi

[1aaaaaaaaaaaaaaa]

Hello, I think something like this may work for you:

Sub Consolidate()

    Dim sheet1 As Worksheet
    Set sheet1 = ThisWorkbook.Sheets("Sheet1")
    
    Dim results As Worksheet
    Set results = ThisWorkbook.Sheets("RESULTS")
    
    results.Cells.Clear
    
    Dim resultsTargetRng As Range
    Set resultsTargetRng = results.Range("A4")
    
    Dim cell As Range
    
    For Each cell In sheet1.UsedRange.Columns("A").Cells
    
        If cell.Value <> "" Then
        
            resultsTargetRng.Value = cell.Value
            resultsTargetRng.Offset(0, 1).Value = cell.Offset(0, 5).Value + cell.Offset(0, 8).Value + cell.Offset(0, 11).Value
            
            Set resultsTargetRng = resultsTargetRng.Offset(1, 0)
            
        End If
    
    Next

End Sub

[RIZVI]

Hi Poizhan,

Thank you for your reply. Checked, but this is not what I require.

the result should appear in the same data sheet, SHEET1.
My RESULTS sheet is only a sample output. But all should appear in SHEET1.

The result should start from row 4 (A4 for names and F4 for the sum)
There cannot be duplicate names. Your code gives duplicate names.

Plsd to hear

Regards
Rizvi

[1aaaaaaaaaaaaaaa]

Got it, sorry for the confusion my friend. Please try this:

Sub Consolidate()

    Dim sheet1 As Worksheet
    Set sheet1 = ThisWorkbook.Sheets("Sheet1")
    
    Dim startResultsRow As Long
    startResultsRow = sheet1.UsedRange.Rows.Count + 6
    
    Dim resultsTargetRng As Range
    Set resultsTargetRng = sheet1.Range("A" & startResultsRow)
    
    Dim cell As Range
    
    For Each cell In sheet1.UsedRange.Columns("A").Cells
    
        If cell.Value <> "" Then
            
            Dim foundRow As Long
            foundRow = 0
            
            Dim loopTargetRng As Range
            Set loopTargetRng = sheet1.Range("A" & startResultsRow)
            
            While loopTargetRng.Value <> ""
            
                If loopTargetRng.Value = cell.Value Then foundRow = loopTargetRng.Row
            
                Set loopTargetRng = loopTargetRng.Offset(1, 0)
            
            Wend
            
            If foundRow > 0 Then
            
                sheet1.Range("F" & foundRow).Value = sheet1.Range("F" & foundRow).Value + cell.Offset(0, 5).Value + cell.Offset(0, 8).Value + cell.Offset(0, 11).Value
            
            Else
            
                resultsTargetRng.Value = cell.Value
                resultsTargetRng.Offset(0, 5).Value = cell.Offset(0, 5).Value + cell.Offset(0, 8).Value + cell.Offset(0, 11).Value
                Set resultsTargetRng = resultsTargetRng.Offset(1, 0)
            
            End If
            
        End If
    
    Next
    
    sheet1.Rows("2:" & startResultsRow - 3).Delete

End Sub

[RIZVI]

As I woke up this morning, it was like "MAJIC (LOVE) IS IN THE AIR, EVERY WHERE I LOOK AROUND"!
Perfectly working as per my requirement. The code means a lot to me.
Thank you buddy, appreciated here

Best wishes
Rizvi

[RIZVI]

Hi William,

Extremely sorry for this oversight. But noted that items are checked for duplicates as it is.
example: Banana, banana, BaNana

With above example, although it is the same spelling, it gives 3 different rows.

Is it possible to only fetch the first located item (Banana) and give the same name in the output since all 3 names are spelt correctly except for the writing method (Upper & Lower letters).

Plsd to hear

Best Wishes
Rizvi

[jindon]

try

Sub test()
    Dim x, r As Range
    With Sheets("sheet1")
        Set r = .UsedRange
        x = .[unique(filter(a:a,a:a<>""))]
    End With
    With Sheets("results").[a4].Resize(UBound(x))
        Union(.CurrentRegion.Columns("a"), .CurrentRegion.Columns("f")).ClearContents
        .Value = x
        .Columns("f") = "=sumproduct((" & r.Columns(1).Address(, , , 1) & "=" & _
            .Cells(1).Address(0, 0) & ")*(" & r.Offset(, 1).Address(, , , 1) & "))"
    End With
End Sub

[RIZVI]

Hello Jindon,

Many thanks for the code. Looks good. But the output has to come into the same sheet (SHEET1 - starting at row 4 - A4 items & F4 sum)
I used RESULT as a sample sheet only which is none existance.

Plsd to hear

Regards
Rizvi

[jindon]

Sub test()
    Dim a, i As Long, ii As Long
    With Sheets("sheet1")
        With .UsedRange
            a = .Value: .ClearContents
        End With
        With CreateObject("Scripting.Dictionary")
            .CompareMode = 1
            For i = 1 To UBound(a, 1)
                If a(i, 1) <> "" Then
                    For ii = 2 To UBound(a, 2)
                        .Item(a(i, 1)) = .Item(a(i, 1)) + a(i, ii)
                    Next
                End If
            Next
            a = Application.Transpose(Array(.keys, .items))
        End With
        With .[a4].Resize(UBound(a, 1))
            .Value = Application.Index(a, 0, 1)
            .Columns("f").Value = Application.Index(a, 0, 2)
        End With
    End With
End Sub

[RIZVI]

I get a run time error

[jindon]

Upload your workbook that gives you such error.

[RIZVI]

My mistake buddy. No idea what happend as continuously got runtime error. I have uploaded the file with code running in thisworkbook. tried code running in sheet1 and there too it works perfectly. thank you very much. reputation added.

still on the same subject, could you assist to merge and center;

1. the items from A4 to E4
2. the sum from F4 to H4

and, it should run down similarly (A5-E5 and F5-H5) till the end of the output

I think this would be the last request on the topic

appreciated once again and thank you for same

best wishes
Rizvi

[jindon]

change

        With .[a4].Resize(UBound(a, 1))
            .Value = Application.Index(a, 0, 1)
            .Columns("f").Value = Application.Index(a, 0, 2)
        End With

to

        With .[a4].Resize(UBound(a, 1))
            For i = 1 To .Rows.Count
                .Cells(i, 1).Resize(, 4).Merge
                .Cells(i, 6).Resize(, 3).Merge
            Next
            Union(.Columns(1), .Columns(6)).HorizontalAlignment = xlCenter
            .Value = Application.Index(a, 0, 1)
            .Columns("f").Value = Application.Index(a, 0, 2)
        End With

[RIZVI]

Hi Jindon,

Perfecto!!!!!

Thank buddy

Rizvi