20170324xlVBA最简单分类计数

Sub NextSeven_CodeFrame()
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Application.Calculation = xlCalculationManual
    Application.StatusBar = ">>>>>>>>程序正在运行>>>>>>>>"


    \'On Error GoTo ErrHandler

    Dim StartTime, UsedTime As Variant
    StartTime = VBA.Timer
    \'>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
Dim Dic As Object
Set Dic = CreateObject("Scripting.Dictionary")
    
    Dim Wb As Workbook
    Dim Sht As Worksheet
    Dim oSht As Worksheet
    Dim Rng As Range
    Dim Arr As Variant
    Dim EndRow As Long
    Const HEAD_ROW As Long = 1
    Const SHEET_NAME As String = "数据"
    Const START_COLUMN As String = "A"
    Const END_COLUMN As String = "Z"

    Const OTHER_HEAD_ROW As Long = 1
    Const OTHER_SHEET_NAME As String = "重复"

    \'>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
    Set Wb = Application.ThisWorkbook
    Set Sht = Wb.Worksheets(SHEET_NAME)
    With Sht
        EndRow = .Cells(.Cells.Rows.Count, 1).End(xlUp).Row
        Set Rng = .Range(.Cells(HEAD_ROW + 1, START_COLUMN), .Cells(EndRow, END_COLUMN))

        Arr = Rng.Value
        For i = LBound(Arr) To UBound(Arr)
            
            Key = "\'" & CStr(Arr(i, 4))
            If Key <> "\'" Then
            Dic(Key) = Dic(Key) + 1
            End If
        Next i
    End With
    
     \'>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
     For Each onekey In Dic.KEYS
        If Dic(onekey) < 2 Then
            Dic.Remove onekey
        End If
     Next onekey
     
    \'>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
    Set oSht = Wb.Worksheets(OTHER_SHEET_NAME)
    With oSht
       .Cells.ClearContents
       .Range("A1:B1").Value = Array("ID", "次数")
       If Dic.Count > 0 Then
        .Range("A2").Resize(Dic.Count, 2).Value = Application.WorksheetFunction.Transpose(Array(Dic.KEYS, Dic.ITEMS))
       End If
    End With


    \'>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
    UsedTime = VBA.Timer - StartTime
    MsgBox "本次耗时：" & Format(UsedTime, "0.000秒"), vbOKOnly, "NextSeven Excel Studio"

ErrorExit:
      Set Wb = Nothing
      Set Sht = Nothing
      Set Rng = Nothing
      Set oSht = Nothing
      Set Dic = Nothing

    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Application.Calculation = xlCalculationAutomatic
    Application.StatusBar = False
    Exit Sub
    \'>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
ErrHandler:
    If Err.Number <> 0 Then
        MsgBox Err.Description & "！", vbCritical, "NextSeven Excel Studio"
        \'Debug.Print Err.Description
        Err.Clear
        Resume ErrorExit
    End If
End Sub