Option Explicit'Автор Б. Виталий В. (bedvit)
'Макрос записан: 21/10/2016
'Редакция: 6 от 26/02/2020
'Действие: выделение разными цветами дубликатов в выделенных диапазонах
Sub select_replica() 'рабочий
Dim R As Range, Rf As Range, Rc As Range, i As Long, s(3) As Long, ac, t, x, cell
Dim Dict: Set Dict = CreateObject("Scripting.Dictionary")
Dim DictColor: Set DictColor = CreateObject("Scripting.Dictionary")
t = Timer
On Error Resume Next
If Selection.CountLarge = 1 Then
Set Rf = ActiveSheet.UsedRange.SpecialCells(xlCellTypeFormulas, 23)
Set Rc = ActiveSheet.UsedRange.SpecialCells(xlCellTypeConstants, 23)
Else
Set Rf = Intersect(ActiveSheet.UsedRange, Selection).SpecialCells(xlCellTypeFormulas, 23)
Set Rc = Intersect(ActiveSheet.UsedRange, Selection).SpecialCells(xlCellTypeConstants, 23)
End If
On Error GoTo 0
With Application: .ScreenUpdating = 0: .DisplayAlerts = 0: .EnableEvents = 0: ac = .Calculation: .Calculation = -4135: .StatusBar = "BE: обработка данных...": End With
Set R = Rf: GoSub Go_
Set R = Rc: GoSub Go_
With Application: .ScreenUpdating = 1: .DisplayAlerts = 1: .EnableEvents = 1: .Calculation = ac: .StatusBar = False: End With
Debug.Print "select_replica = " & Timer - t
MsgBox "Выделено разных групп дубликатов (разными цветами): " & i, vbInformation
Exit Sub
Go_:
If Not R Is Nothing Then
R.Interior.Pattern = Empty
For Each cell In R.Cells
If Dict.Exists(cell.Value) Then
x = Dict.Item(cell.Value)
If x(3) = 1 Then
i = i + 1
x(2) = 6740479
cell.Interior.Color = x(2)
Else
s(0) = cell.Row
s(1) = cell.Column
s(3) = 1
Dict.Add cell.Value, s
End If
Next
End If
Return
End Sub
Function Generate_nice_color() As Long
Dim R As Long, G As Long, B As Long
Do
Randomize
R = Int(Rnd * 256)
G = Int(Rnd * 256)
B = Int(Rnd * 256)
Loop Until R + G + B > 500 And R + G + B < 700
Generate_nice_color = RGB(R, G, B)
End Function
Иногда при сравнении больших массивов, на сотни тысяч ячеек, может быть всего несколько дублей, и их не получается найти через стандартный фильтр эксель. Вопрос можно ли усовершенствовать макрос так чтобы, он после поиска дублей, правее сравниваемого столбца, напротив ячейки с залитым цветом дублем, писал слово дубль. Пример ищем дубли в столбце В:В, макрос их нашёл и в столбце С:С напротив дублей написал слово Дубль.
Option Base 1
Option Explicit
Option Private Module
'====================================================================================================
Sub PRDX_DuplReport()
Dim dic As New Dictionary
Dim rng As Range, aDic(), aOne(1, 1)
Dim arr, v$, txCol$, t!, a&, r&, rr&, c&, n&, d&, fR&, fC&, VT&, AC&
t = Timer
Set rng = Selection: If rng.Cells.Count = 1 Then Set rng = ActiveSheet.UsedRange Else Set rng = Intersect(rng, ActiveSheet.UsedRange)
If rng.Cells.Count = 1 Then MsgBox "There is Only ONE Cell on a WorkSheet", vbInformation, "DuplReport": Exit Sub
ReDim aDic(rng.Cells.Count, 3) ' Arr2D: StrValue, Address, Count
For a = 1 To rng.Areas.Count
With rng.Areas(a).Cells(1, 1): fR = .Row - 1: fC = .Column - 1: End With
arr = rng.Areas(a).Value: If Not IsArray(arr) Then aOne(1, 1) = arr: arr = aOne
For c = 1 To UBound(arr, 2)
txCol = PRDX_RngColConvert_NumToLtr(fC + c)
For r = 1 To UBound(arr, 1)
VT = VarType(arr(r, c)): If VT < 2 Then GoTo nx Else If VT > 8 Then GoTo nx Else If Len(arr(r, c)) = 0 Then GoTo nx
n = n + 1: v = arr(r, c)
Select Case dic.Exists(v)
Case True: rr = dic(v): aDic(rr, 2) = aDic(rr, 2) & "," & txCol & fR + r: aDic(rr, 3) = aDic(rr, 3) + 1
Case Else: d = d + 1: aDic(d, 2) = txCol & fR + r: aDic(d, 3) = 1: aDic(d, 1) = v: dic.Add v, d
End Select
nx: Next r
Next c
Next a
If d = 0 Then MsgBox "There is NO any current Values!", vbExclamation, Format$(Timer - t, "0.00 sec"): Exit Sub
If d = 1 Then MsgBox "There is only ONE Uniq Value!", vbExclamation, Format$(Timer - t, "0.00 sec"): Exit Sub
Application.ScreenUpdating = False
AC = Application.Calculation: Application.Calculation = xlCalculationManual
Worksheets.Add After:=ActiveSheet
Columns(1).NumberFormat = "@"
Cells(1, 1).Resize(1, UBound(aDic, 2)).Value2 = Array("StrValue", "Addresses", "Count")
Cells(2, 1).Resize(d, UBound(aDic, 2)).Value = aDic
Application.ScreenUpdating = True
Application.Calculation = AC
MsgBox "UniqList (" & Format$(d, "#,##0") & ") of Values (" & Format$(n, "#,##0") & ") was created!", vbInformation, Format$(Timer - t, "0.00 sec")
End Sub
'====================================================================================================
Function PRDX_RngColConvert_NumToLtr(ByVal nCol&) As String
Dim ch&, i&
Static a(16384) As String, fStatic As Boolean
If Not fStatic Then
fStatic = True
For ch = 65 To 90
i = i + 1: a(i) = Chr$(ch)
Next ch
For i = 27 To 16384
a(i) = ColToLtr(i)
Next i
End If
PRDX_RngColConvert_NumToLtr = a(nCol)
End Function
'----------------------------------------------------------------------------------------------------
Private Function ColToLtr(nCol&) As String
Dim cQUO As Long, cMOD As Long, cQUO2 As Long, cMOD2 As Long
If nCol <= 702 Then
cQUO = nCol \ 26
cMOD = nCol Mod 26
If cMOD = 0 Then cQUO = cQUO - 1: cMOD = 26
ColToLtr = Chr$(cQUO + 64) & Chr$(cMOD + 64)
Else
cQUO = nCol \ 26
cMOD = nCol Mod 26
cQUO2 = (nCol - 26) \ 676
cMOD2 = (nCol - 26) Mod 676
If cMOD2 = 0 Then cQUO2 = cQUO2 - 1
If cMOD = 0 Then cQUO = cQUO - 1: cMOD = 26
ColToLtr = Chr$(cQUO2 + 64) & Chr$((cQUO - cQUO2 * 26) + 64) & Chr$(cMOD + 64)
End If
End Function
'====================================================================================================
• Если выделена одна ячейка, то будет использована вся рабочая область листа. В противном случае - только выделение. • Ошибки, а также пустые и логические значения игнорируются. • Значения преобразуются в текстовый вид, поэтому 1 и "1" будут считаться одним "1" ключом. Если не надо, то заменить в начале кода v$ на v. • Регистр учитывается, поэтому "Вася" и "вася" - это разные ключи. Если нужно игнорировать, то заменить v = arr(r, c) на v = LCase$(arr(r, c)). В список, в таком случае, будут выведены ключи (значения) в нижнем регистре. • В отчёте (уникальный список всех значений) присутствуют как дубликаты, так и уникальные значения (столбец Count - количество вхождений значения).
При необходимости полученные блоки строк адресов (перечень ячеек с одним и тем же значением) можно быстро закрасить разными цветами.
P.S.: Функция Generate_nice_color()не гарантирует уникальности полученного цвета, поэтому разные группы дубликатов могут быть окрашены одинаковым цветом. Впрочем, у вас в макросе она и не используется (тогда зачем она)
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
написал: Впрочем, у вас в макросе она и не используется (тогда зачем она)
А она и не нужна, макрос всё красит в цвет похожий на жёлтый для удобства фильтрации. Огромное спасибо Вам за проделанную работу, очень круто сделано, но в реальной задаче нужен именно макрос. Меня старый макрос устраивает, но оказалось что когда из 240 000 ячеек всего 9 дублей и машина их красит, то фильтр эксель не может отфильтровать по цвету, из-за этого эти дубли не вычленить.
Как вариант: может можно новый код написать что если в выделенном диапазоне ячейка покрашена в цвет 6740479 то напротив неё, правее столбца пишет слово дубль. Ігор Гончаренко, написал вот такой код который красит ячейки
Код
Sub FillB2s()
Dim ws As Worksheet
For Each ws In Worksheets
If ws.[b2] <> 1 Then ws.[b2].Interior.Color = 255
Next
End Sub
я думаю можно сделать наоборот, но не знаю и не понимаю как прописать диапазоны сравнения, а не точные координаты ячеек как у Игоря.
zvolkz: очень круто сделано, но в реальной задаче нужен именно макрос
а у меня что? Не понимаю, чем не устраивает и что вам даст вывод в соседнюю ячейку но можно просто заменить строку "вашего" кода №38: cell.Interior.Color = x(2) на cell.Interior.Color = x(2): cell.Offset(0,1).Value2="ДУБЛЬ"
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
написал: Не понимаю, чем не устраивает и что вам даст вывод в соседнюю ячейку
Это позволяет с помощью формул делать расчёты. До того как появилась проблема с фильтрами, я в ручную выбирал фильтр по цвету, а потом сам прописывал слово дубль напротив цветных ячеек Ещё раз благодарю за помощь, Ваша таблица будет очень полезной, но других задачах.
zvolkz, пожалуйста) Ваша задача, уверен, решается и без макроса от бедвита - гораздо проще и быстрее, но вы ведь решили, что пример не нужен, а нужно именно "модифицировать" макрос, который изначально вообще для другого создан
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Jack Famous, есть такое). Изначально нужно было вот такую формулу
Код
=СЧЁТЕСЛИ(D:D;D2)>1
сделать в макрос, потому что на сотнях тысяч ячеек она считается часами. В итоге поиски на форуме вывели меня на тему с макросом бедвита, который всё обрабатывал за минуты, 743 000 ячеек минуты за 3 плюс минус.
zvolkz, создайте новую тему с примером и всё будет)
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄