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