count how many rows are consolidated in vba

Question

I have created a macro that consolidates rows that contain the same value in column D and provides the average of the rows consolidated. I am trying to write a line of code inside the code provided below, which will count the individual rows that have been consolidated and paste the result next to the consolidated row (column Q) as it can be sheen form the pictures. Picture 1 contains the initial table and picture 2 contains the consolidated table. any ideas? Much appreciated!

UPDATE!

These are the updated pictures

The whole process is PERFECT until the row Q (it was the last column before the update). I added three more columns to the destination table and one more to the source table.. if it is possible, I want for the column R the macro to consolidate the rows and print their averaged Gross WFR delivered to the column R ONLY if the column I of the row is 0. Also, I want the macro to count these rows (containing 0) that it consolidates (just like it does for column Q) and print the number in column S. Finally, IF it is possible to count the number of these rows (containing 0) that are out of TARGET and print the number in column K. what I mean by out of TARGET is that for these rows K(values)-E(values)>3%.

FINAL UPDATE OF THE CODE

Dim ws As Worksheet Dim dataRng As Range Dim dic As Variant, arr As Variant Dim cnt As Long

Set ws = Sheets("1")

With ws
lastrow = .Cells(.Rows.Count, "D").End(xlUp).Row    'get last row in Column D
Set dataRng = .Range("D2:D" & lastrow)              'range for Column D
Set dic = CreateObject("Scripting.Dictionary")
arr = dataRng.Value

For i = 1 To UBound(arr)
dic(arr(i, 1)) = dic(arr(i, 1)) + 1
Next
.Range("M2").Resize(dic.Count, 1) = Application.WorksheetFunction.Transpose(dic.keys)   'uniques data from Column D
.Range("Q2").Resize(dic.Count, 1) = Application.WorksheetFunction.Transpose(dic.items)
cnt = dic.Count
For i = 2 To cnt + 1
.Range("N" & i & ":P" & i).Formula = "=SUMIF($D$2:$D$" & lastrow & ",$M" & i & ",E$2:E$" & lastrow & ")/" & dic(.Range("M" & i).Value)
.Range("R" & i).Formula = "=IF(INDEX($I$2:$I$" & lastrow & ",MATCH($M" & i & ",$D$2:$D$" & lastrow & ",0))=0,N" & i & ",0)"
.Range("S" & i).Formula = "=IF(INDEX($I$2:$I$" & lastrow & ",MATCH($M" & i & ",$D$2:$D$" & lastrow & ",0))=0,Q" & i & ",0)"
.Range("T" & i).Formula = "=IF($S" & i & ">0,SUMPRODUCT(($D$2:$D$" & lastrow & "=$M" & i & ")*(($J$2:$J$" & lastrow & "-$E$2:$E$" & lastrow & ")>3%)),0)"
Next i
.Range("N" & i & ":T" & i).Formula = "=SUM(N2:N" & cnt + 1 & ")"
.Range("N2:T" & .Cells(.Rows.Count, "M").End(xlUp).Row + 1).Value = .Range("N2:T" & .Cells(.Rows.Count, "M").End(xlUp).Row + 1).Value
End With

Answer 1

Try this:

Sub Demo()
    Dim ws As Worksheet
    Dim dataRng As Range
    Dim dic As Variant, arr As Variant
    Dim cnt As Long

    Set ws = ThisWorkbook.Sheets("Sheet4")  'change Sheet4 to your data sheet

    Application.ScreenUpdating = False
    With ws
        lastRow = .Cells(.Rows.Count, "D").End(xlUp).Row    'get last row in Column D
        Set dataRng = .Range("D2:D" & lastRow)              'range for Column D
        Set dic = CreateObject("Scripting.Dictionary")
        arr = dataRng.Value

        For i = 1 To UBound(arr)
            dic(arr(i, 1)) = dic(arr(i, 1)) + 1
        Next
        .Range("M2").Resize(dic.Count, 1) = Application.WorksheetFunction.Transpose(dic.keys)   'uniques data from Column D
        .Range("Q2").Resize(dic.Count, 1) = Application.WorksheetFunction.Transpose(dic.items)  'count of shipment
        cnt = dic.Count
        For i = 2 To cnt + 1
            .Range("N" & i & ":P" & i).Formula = "=SUMIF($D$2:$D$" & lastRow & ",$M" & i & ",E$2:E$" & lastRow & ")/" & dic(.Range("M" & i).Value)
        Next i
        .Range("N2:P" & .Cells(.Rows.Count, "M").End(xlUp).Row).Value = .Range("N2:S" & .Cells(.Rows.Count, "M").End(xlUp).Row).Value
    End With
    Application.ScreenUpdating = True
End Sub

Assumption: Your data is in range Column D:ColumnG and want output in Column M:ColumnQ.

EDIT :

Sub Demo()
    Dim ws As Worksheet
    Dim dataRng As Range
    Dim dic As Variant, arr As Variant
    Dim cnt As Long

    Set ws = ThisWorkbook.Sheets("Sheet5")  'change Sheet4 to your data sheet

    Application.ScreenUpdating = False
    With ws
        lastRow = .Cells(.Rows.Count, "D").End(xlUp).Row    'get last row in Column D
        Set dataRng = .Range("D2:D" & lastRow)              'range for Column D
        Set dic = CreateObject("Scripting.Dictionary")
        arr = dataRng.Value

        For i = 1 To UBound(arr)
            dic(arr(i, 1)) = dic(arr(i, 1)) + 1
        Next
        .Range("M2").Resize(dic.Count, 1) = Application.WorksheetFunction.Transpose(dic.keys)   'uniques data from Column D
        .Range("Q2").Resize(dic.Count, 1) = Application.WorksheetFunction.Transpose(dic.items)
        cnt = dic.Count
        For i = 2 To cnt + 1
            .Range("N" & i & ":P" & i).Formula = "=SUMIF($D$2:$D$" & lastRow & ",$M" & i & ",E$2:E$" & lastRow & ")/" & dic(.Range("M" & i).Value)
            .Range("R" & i).Formula = "=IF(INDEX($I$2:$I$" & lastRow & ",MATCH($M" & i & ",$D$2:$D$" & lastRow & ",0))=0,N" & i & ","""")"
            .Range("S" & i).Formula = "=IF(INDEX($I$2:$I$" & lastRow & ",MATCH($M" & i & ",$D$2:$D$" & lastRow & ",0))=0,Q" & i & ","""")"
            .Range("T" & i).Formula = "=IF(ISNUMBER($S" & i & "),SUMPRODUCT(($D$2:$D$" & lastRow & "=$M" & i & ")*(($K$2:$K$" & lastRow & "-$E$2:$E$" & lastRow & ")>3%)),"""")"
        Next i
        .Range("N2:T" & .Cells(.Rows.Count, "M").End(xlUp).Row).Value = .Range("N2:T" & .Cells(.Rows.Count, "M").End(xlUp).Row).Value
    End With
    Application.ScreenUpdating = True
End Sub

EDIT 2 :

Instead of

.Range("N2:T" & .Cells(.Rows.Count, "M").End(xlUp).Row).Value = .Range("N2:T" & .Cells(.Rows.Count, "M").End(xlUp).Row).Value

write

.Range("N" & i & ":T" & i).Formula = "=SUM(N2:N" & cnt + 1 & ")"
.Range("N2:T" & .Cells(.Rows.Count, "M").End(xlUp).Row + 1).Value = .Range("N2:T" & .Cells(.Rows.Count, "M").End(xlUp).Row + 1).Value

EDIT 3 :

Sub Demo_SO()
    Dim ws As Worksheet
    Dim dataRng As Range
    Dim dic As Variant, arr As Variant
    Dim cnt As Long

    Set ws = ThisWorkbook.Sheets("Sheet5")  'change Sheet4 to your data sheet

    Application.ScreenUpdating = False
    With ws
        lastRow = .Cells(.Rows.Count, "D").End(xlUp).Row    'get last row in Column D
        Set dataRng = .Range("D2:D" & lastRow)              'range for Column D
        Set dic = CreateObject("Scripting.Dictionary")
        arr = dataRng.Value

        For i = 1 To UBound(arr)
            dic(arr(i, 1)) = dic(arr(i, 1)) + 1
        Next
        .Range("M2").Resize(dic.Count, 1) = Application.WorksheetFunction.Transpose(dic.keys)   'uniques data from Column D
        .Range("Q2").Resize(dic.Count, 1) = Application.WorksheetFunction.Transpose(dic.items)
        cnt = dic.Count
        For i = 2 To cnt + 1
            .Range("N" & i & ":P" & i).Formula = "=SUMIF($D$2:$D$" & lastRow & ",$M" & i & ",E$2:E$" & lastRow & ")/" & dic(.Range("M" & i).Value)
            .Range("R" & i).Formula = "=IF(INDEX($I$2:$I$" & lastRow & ",MATCH($M" & i & ",$D$2:$D$" & lastRow & ",0))=0,N" & i & ",0)"
            .Range("S" & i).Formula = "=IF(INDEX($I$2:$I$" & lastRow & ",MATCH($M" & i & ",$D$2:$D$" & lastRow & ",0))=0,Q" & i & ",0)"
            .Range("T" & i).Formula = "=IF($S" & i & ">0,SUMPRODUCT(($D$2:$D$" & lastRow & "=$M" & i & ")*(($K$2:$K$" & lastRow & "-$E$2:$E$" & lastRow & ")>3%)),0)"
        Next i
        .Range("N" & i & ":T" & i).Formula = "=SUM(N2:N" & cnt + 1 & ")"
        .Range("N2:T" & .Cells(.Rows.Count, "M").End(xlUp).Row + 1).Value = .Range("N2:T" & .Cells(.Rows.Count, "M").End(xlUp).Row + 1).Value
    End With
    Application.ScreenUpdating = True
End Sub