На 1кк номеров справляется за 1,9 сек (только сортировка) на рабочем компе.
Из "Е" столбца выбирает номера телефонов, превращает их в числа, сортирует, считает дубли, выгружает в столбец "I" список повторов.
Код |
---|
Type mDbl: d As Double: End Type
Type bArr: b(7) As Byte: End Type
Sub Idx()
Dim Arr(), qq(), aa&(), a&, b&, c&
With ActiveSheet
a = .Cells(.Rows.Count, "E").End(xlUp).Row
Arr = .Range("E2:E" & a).Value: ReDim qq(1 To UBound(Arr), 1 To 1)
For a = 1 To UBound(Arr): Arr(a, 1) = CDbl(Mid$(Arr(a, 1), 2)): Next
i = Timer
NumSort Arr(), 1, aa()
Debug.Print Timer - i
For a = 1 To UBound(Arr) - 1
b = 1: qq(a, 1) = b
Do While Arr(aa(a), 1) = Arr(aa(a + 1), 1)
qq(aa(a), 1) = b: b = b + 1: a = a + 1
If a = UBound(Arr) Then Exit Do
Loop
Next: qq(aa(a), 1) = b
.[I2].Resize(a, 1) = qq
End With
End Sub
Sub NumSort(Arr(), ByVal n&, aa&())
Dim bMap(), bb() As bArr, d As mDbl, m&, p&
Dim a&, b&, c&, dd&(), x&, xx&
'------------------------------------------------------
ReDim bb(1 To (UBound(Arr) - LBound(Arr) + 1)): ReDim dd(LBound(Arr) To UBound(Arr))
x = LBound(Arr) And 1 Xor 1
For a = LBound(Arr) To UBound(Arr)
d.d = Arr(a, n): LSet bb(a + x) = d: dd(a) = a
If bb(a + x).b(7) And 128 Then m = m + 1 Else p = p + 1
Next
For a = 3 To 7: ReDim bMap(0 To 255): c = 0
For b = LBound(dd) To UBound(dd)
bMap(bb(dd(b)).b(a)) = bMap(bb(dd(b)).b(a)) + 1
Next
For b = LBound(dd) To UBound(dd)
If IsArray(bMap(bb(dd(b)).b(a))) Then
bMap(bb(dd(b)).b(a))(0) = bMap(bb(dd(b)).b(a))(0) + 1: bMap(bb(dd(b)).b(a))(bMap(bb(dd(b)).b(a))(0)) = dd(b)
Else: ReDim aa(0 To bMap(bb(dd(b)).b(a))): aa(0) = 1: aa(1) = dd(b): bMap(bb(dd(b)).b(a)) = aa
End If
Next: xx = LBound(dd)
For b = 0 To 255
If IsArray(bMap(b)) Then
For c = 1 To bMap(b)(0): dd(xx) = bMap(b)(c): xx = xx + 1: Next
End If
Next
Next: Erase bMap: aa = dd: p = m + 1
For a = LBound(dd) To UBound(dd)
If bb(dd(a)).b(7) And 128 Then aa(m) = dd(a): m = m - 1 Else: aa(p) = dd(a): p = p + 1
Next: dd = aa
For a = 2 To UBound(aa): x = a
Do While Arr(dd(x - 1), n) > Arr(aa(a), n)
dd(x) = dd(x - 1): x = x - 1
If x = 1 Then Exit Do
Loop
dd(x) = aa(a)
Next: aa = dd: Erase dd
End Sub |