count the nos and sum the same no and create summry based on datash pp.

hi
i have this module but it too slow is there way to do it speedily do this .

Sub count_nsum()

    Dim ws3 As Worksheet, ws2 As Worksheet
    Dim dic As Object, w, y
    Dim A, i, ii As Long
    Set dic = CreateObject("Scripting.Dictionary")
    Set ws3 = Sheets("pp")    ' alter if needed
    With ws3.Range("G5:G500").CurrentRegion
        A = .Value
    End With
    For i = LBound(A, 1) To UBound(A, 1)
        If Not IsEmpty(A(i, 6)) Then
            If Not dic.exists(A(i, 6)) Then
                ReDim w(6 To 7)    'check instance in column F and sum column G
                For ii = 6 To 7
                    w(ii) = A(i, ii)
                Next
                dic.Add A(i, 6), w
            Else
                w = dic(A(i, 6)): w(7) = Val(w(7)) + Val(A(i, 7))
                dic(A(i, 6)) = w
            End If
        End If
    Next
    y = dic.items: Set dic = Nothing
    On Error Resume Next
    Set ws2 = Sheets("Summary")
    If ws2 Is Nothing Then
        Set ws2 = Sheets.Add
        ws2.Name = ("Summary")
    End If
    On Error GoTo 0
    With ws2.Range("a1")
        .CurrentRegion.ClearContents
        With .Range("a1")
            For i = LBound(y) To UBound(y)
                .Offset(i).Resize(, UBound(y(i))) = y(i)
            Next
        End With
    End With
    Dim ws1 As Worksheet
    Set ws1 = Nothing: Set ws2 = Nothing
    Erase A, y, w
    Sheets("Summary").Select
    [C:H].ClearContents
    [A1:B2].ClearContents
    Columns("A:B").Select
    Selection.Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlGuess, _
                   OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
                   DataOption1:=xlSortNormal
    Sheets("pp").Select
    ' # code of CountNos_2 data
    Dim RNG1 As Range, aA, B, c1(), i2 As Long, ii2 As Long, myNum As Double, N As Long
    Set RNG1 = Range("F:F")    'Application.InputBox("Select Per Day column F data range", Type:=8)
    If RNG1 Is Nothing Then Exit Sub
    aA = RNG1.Value: Set Rng = Nothing
    Set RNG1 = Range("G:G")    'Application.InputBox("Select Rm. Rate column G data range", Type:=8)
    If RNG1 Is Nothing Then Exit Sub
    B = RNG1.Resize(UBound(aA, 1), 4).Value
    myNum = 60    'Application.InputBox("Enter the Rate to be less then to count usually 50", Type:=1)
    ReDim c1(1 To UBound(aA, 1), 1 To 5)
    With CreateObject("Scripting.Dictionary")
        .CompareMode = vbTextCompare
        For i2 = 1 To UBound(aA, 1)
            If Not .exists(aA(i2, 1)) Then
                N = N + 1: c1(N, 1) = aA(i2, 1): .Item(aA(i2, 1)) = N
            End If
            For ii2 = 1 To 4
                If (B(i2, ii2) >= 0) * (B(i2, ii2) < myNum) Then    'use this for num range >0 to input num
                    c1(.Item(aA(i2, 1)), ii2 + 1) = c1(.Item(aA(i2, 1)), ii2 + 1) + 1
                End If
            Next
        Next
    End With
    With Sheets("Summary").Cells(3)    'starting column nos on respected sheet name
        ' #       2 for 2 column data 3 for 3 column data
        .Resize(, 2).Value = Array("Per Day Rate", "Rate less then" & myNum)    ', _
                                                                                '"Score2_less_" & myNum, "Score3_less_" & myNum, "Score4_less_" & myNum)
        With .Offset(1).Resize(N, 2)
            .Value = c1
            On Error Resume Next
            .SpecialCells(4).Value = 0
        End With
    End With


    Sheets("Summary").Select
    [C1:D2].ClearContents
    [C:D].Activate
    Selection.Sort Key1:=Range("C1"), Order1:=xlAscending, Header:=xlGuess, _
                   OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
                   DataOption1:=xlSortNormal
    [E1].Activate
    Set r = Nothing
    Application.ScreenUpdating = True

End Sub

also here is the sample wb

Hi,

Can you explain in a narrative with reference to your pp data how you are summarising it. i.e. what rules are you using.

I can't help thinking that standard Excel functionality might achieve the task in a much quicker way.

Originally Posted by Richard Buttrey

Hi,

Can you explain in a narrative with reference to your pp data how you are summarising it. i.e. what rules are you using.

I can't help thinking that standard Excel functionality might achieve the task in a much quicker way.

hi Richard Buttrey
in sh "pp" code should look in Column F find 1st instance says value 25.00 ,then in same column find next instance of value 25.00 count that instance and also sum that same ,then goto next value say 30.00 find value instance in column F and count and sum
so the summery sheet should look like following manner
value| sum|nos of occurrence |
25 |125 |5
30 |240 |8
50 |100 |2
.
.
.
so on all value in column G
hope i explain it
thanks

Hi,

I don't see values for 25 & 30 (A1&A2 in Summary)

Neither do I understand where values like 161.45 (B3) come from. I see that there are 5 occurencies of 37.14 (A3) but 5 x 37.14 = 185.7.
Please explain the calculations in column B

hi Richard Buttrey
in sh "pp" code should look in Column f find 1st instance says value 25.00 ,then in same column find next instance of value 25.00 count that instance and also sum that same ,then goto next value say 30.00 find value instance in column F and count and sum
so the summery sheet should look like following manner
value| sum|nos of occurrence |
25 |125 |5
30 |240 |8
50 |100 |2
.
.
.
so on all value in column G
hope i explain it
thanks