Option Explicit
'===========================================================================================
Sub MarkDuplicates()
Dim arr(), arrAdr() As String, r&, i&, txtCompare$, tm!
Const mark$ = "жопка"
tm = Timer: arr = Worksheets("все").[a2:c317].Value2: If Not Array2xSort_Text(arr, 2) Then MsgBox "Сортировка не выполнена", vbCritical, "ОШИБКА": Exit Sub
ReDim arrAdr(0 To UBound(arr, 1)): i = -1
For r = 2 To UBound(arr, 1)
If arr(r, 2) = arr(r - 1, 2) Then
If arr(r, 1) <> arr(r - 1, 1) Then i = i + 1: arrAdr(i) = arr(r, 2)
End If
Next r
txtCompare = "•" & Join(arrAdr, "•") & "•"
For r = 1 To UBound(arr, 1)
If InStr(1, txtCompare, "•" & arr(r, 2) & "•") Then arr(r, 3) = mark
Next r
Worksheets("все").[e2].Resize(UBound(arr, 1), UBound(arr, 2)).Value2 = arr
MsgBox "Макрос успешно завершён за " & Format$(Timer - tm, "0.00 сек"), vbInformation, "ГОТОВО"
End Sub
'===========================================================================================
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'МОЗГИ: ТЕКСТОВЫЙ сортер 2x-массива от Anchoret: https://www.planetaexcel.ru/forum/index.php?PAGE_NAME=message&FID=1&TID=98837&TITLE_SEO=98837-sortirovka-v-dvumernom-massive-vba-excel&MID=955983#message955983
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Public Function Array2xSort_Text(arr2xTmp(), Optional ByVal nSort As Byte = 1) As Boolean
Dim bMap(), bb() As Byte, x&, xx&
Dim a&, b&, c&, d&, dt$, cc(), lMax&, dd&(), aa&()
ReDim dd(LBound(arr2xTmp) To UBound(arr2xTmp)): lMax = 3: x = 3
For a = LBound(arr2xTmp) To UBound(arr2xTmp): dd(a) = a: Next a
If LBound(arr2xTmp) = 0 Then d = lMax Else d = 0
dt = Space(lMax * (UBound(arr2xTmp) - LBound(arr2xTmp) + 1)): b = 1
For a = LBound(arr2xTmp) To UBound(arr2xTmp)
Mid$(dt, b, lMax) = Mid$(arr2xTmp(dd(a), nSort), 1, lMax): b = b + lMax
Next a
bb = StrConv(dt, 128): dt = vbNullString
For b = x To 1 Step -1
xx = LBound(arr2xTmp): ReDim bMap(32 To 255)
For a = LBound(dd) To UBound(dd)
x = dd(a) * lMax - lMax + d + b - 1: bMap(bb(x)) = bMap(bb(x)) + 1
Next a
For a = LBound(dd) To UBound(dd)
x = dd(a) * lMax - lMax + d + b - 1
If IsArray(bMap(bb(x))) Then
bMap(bb(x))(0) = bMap(bb(x))(0) + 1: bMap(bb(x))(bMap(bb(x))(0)) = dd(a)
Else
ReDim aa(0 To bMap(bb(x)) + 1): aa(0) = 1: aa(1) = dd(a): bMap(bb(x)) = aa
End If
Next a
For a = 32 To 255
If IsArray(bMap(a)) Then
For x = 1 To bMap(a)(0): dd(xx) = bMap(a)(x): xx = xx + 1: Next x
End If
Next a
Next b
ReDim aa(LBound(dd) To UBound(dd)): aa(LBound(aa)) = dd(LBound(dd)): Erase bb
For a = LBound(dd) + 1 To UBound(dd)
b = a
Do While StrComp(arr2xTmp(aa(b - 1), nSort), arr2xTmp(dd(a), nSort), 0) = 1
aa(b) = aa(b - 1): b = b - 1: If b = LBound(aa) Then Exit Do
Loop
aa(b) = dd(a)
Next a
Erase dd: Erase bMap: x = LBound(arr2xTmp, 2): xx = UBound(arr2xTmp, 2)
ReDim cc(LBound(arr2xTmp) To UBound(arr2xTmp), x To xx)
For a = LBound(aa) To UBound(aa)
For b = x To xx: cc(a, b) = arr2xTmp(aa(a), b): Next b
Next a
arr2xTmp = cc: Erase aa: Erase cc: Array2xSort_Text = True
End Function |