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