|
- Sub 求指定重复数()
- Dim arr1, arr2, arrTemp, a
- Dim i As Long
- Dim j As Byte
- Dim dic As Object
-
- Application.ScreenUpdating = False
-
- '分别是重复次数,统计数据
- arr1 = Range("i1").CurrentRegion
- arr2 = Range("i4").CurrentRegion
-
- '字典
- Set dic = CreateObject("scripting.dictionary")
- '清除A列
- Columns("a") = ""
-
- For i = LBound(arr1, 2) To UBound(arr1, 2)
- '取重复数次
- j = arr1(1, i)
- '取每一列数据
- arrTemp = WorksheetFunction.Index(arr2, 0, i)
-
- '统计重复次数
- For Each a In arrTemp
- dic(a) = dic(a) + 1
- Next
-
- '非指定重复次数的删除
- For Each a In dic.keys
- If dic(a) <> j Then
- Debug.Print dic(a)
- dic.Remove (a)
- End If
- Next
-
- '检测字典内数据个数,然后输出
- If dic.Count > 0 Then Range("a" & Cells(Rows.Count, 1).End(xlUp).Row + 1).Resize(dic.Count) = WorksheetFunction.Transpose(dic.keys)
- '字典清空
- dic.RemoveAll
- Next
-
- Application.ScreenUpdating = True
- MsgBox "整理完成"
- End Sub
复制代码 |
|