Сравнение двух таблиц выделение совпадающих ячеек

[derlysh]

Помогите плиззз
Нужен макрос для сравнение двух таблиц, выделение совпадающих ячеек (совпадение должно быть полностью) и их сортировка т.е. на совпадение по ячейкам
в ячейках есть цифры,буквы и цифры так же цифры со звездочкой впереди

пример:

*00153679
*00153679
00004501/12
00004501/12
0701041000-011
0701041000-011
0701041000-015
7802-754
7802-761
7802-761
7802-762
ОХ2657
ОХ2657
ОХ2660
ОХ2660
ОХ2661
ОХ2661

[Hugo121]

А повторы зачем?
И вообще - зачем ВЫДЕЛЕНИЕ?

[doober]

Вот такая картина почучается,это правильно определены совпадения совпадения.Их около 30 тысяч.Могу написать макрос.но только уже завтра

файл1.............................. ..............Файл2
A2 0701100000-135..................A26001 0701100000-135
A2 0701100000-135..................A26002 0701100000-135
A3 0701101000-636..................A26045 0701101000-636
A3 0701101000-636..................A26046 0701101000-636
A4 0701101000-644..................A26049 0701101000-644
A4 0701101000-644..................A26050 0701101000-644
A5 0701037005-271..................A20914 0701037005-271
A5 0701037005-271..................A20915 0701037005-271
A6 0701001256-016..................A7669 0701001256-016
A6 0701001256-016..................A7670 0701001256-016
A7 0701001256-019..................A7675 0701001256-019
A7 0701001256-019..................A7676 0701001256-019
A8 0701001288-016..................A7741 0701001288-016
A8 0701001288-016..................A7742 0701001288-016
A9 0701098001-437..................A25262 0701098001-437
A9 0701098001-437..................A25263 0701098001-437
A10 0701098001-439.................A25264 0701098001-439
A10 0701098001-439.................A25265 0701098001-439

[alex77755]

Тупо в лоб. Обе книги должны быть открыты.
Загоняем обе в массивы. Потом первый массив в словарь и проверяем второй на совпадения. В случае совпадения выделяем цветом

Sub QWERTY()
Dim W1 As Workbook
Dim W2 As Workbook
Set W1 = Application.Workbooks("1.xlsm")
Set W2 = Application.Workbooks("2.xlsm")
Dim M1()
Dim M2()

Dim LR1
Dim LR2
ReDim R1(1, 0)
ReDim R2(1, 0)

Dim Dict As Object
Set Dict = CreateObject("Scripting.Dictionary")

LR1 = W1.ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
LR2 = W2.ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
W1.Activate
With W1.Sheets(1).Select
M1 = Range(Cells(1, 1), Cells(LR1, 1)).Value
End With
W2.Activate
M2 = Range(Cells(1, 1), Cells(LR2, 1)).Value
'загоняем в словарь первый лист
With Dict
    For i = 1 To UBound(M1)
        If Not .Exists(M1(i, 1)) Then
           .Add M1(i, 1), 1
        End If
    Next i
'ищем совпадения во втором и выделяем цветом
    For i = 1 To UBound(M2)
      If .Exists(M2(i, 1)) Then
      Cells(i, 1).Interior.Color = RGB(255, 255, 0)
      End If
    Next i
End With

Dict.RemoveAll
W1.Activate
'загоняем в словарь второй лист
With Dict
    For i = 1 To UBound(M2)
        If Not .Exists(M2(i, 1)) Then
           .Add M2(i, 1), 1
        End If
    Next i
'ищем совпадения в первом и выделяем цветом
    For i = 1 To UBound(M1)
      If .Exists(M1(i, 1)) Then
      Cells(i, 1).Interior.Color = RGB(255, 255, 0)
      End If
    Next i
End With

End Sub

сортировку не делал - проще сделать средствами ексела

[derlysh]

doober -да именно так нужно

[Hugo121]

Сообщение от derlysh

doober -да именно так нужно

- а ведь сперва нужно было выделить...
И непонятно, зачем рядом два одинаковых столбца выводить - хватило бы и одного.
Повторы тоже непонятно зачем - может рядом с номером писать количество повторов (если оно нужно) - так имхо практичнее.
Как я вижу - делаем по алгоритму alex77755, только в Item первого (и единственного) словаря собираем количество повторов.
Потом проверяем второй массив по словарю, и найденные копируем в третий массив, рядом пишем счётчик "нахождений" (ну или просто копируем столько раз, сколько нашлось). В Item счётчик каждый раз уменьшаем.
В конце итоговый массив выгружаем. Если нужно получить как в примере doober - два раза рядом

[alex77755]

Считать повторы, вроде не стояла задача?
Два словаря чтобы выделить взаимное совпадение в обоих списках
Добавил массив совпадений. Выводится на лист2

[Hugo121]

Считать не стояла, но если то, что показал doober - good, то нужно считать
Как иначе сделать на словаре, если в одном списке допустим 7802-761 три раза, а вдругом два?

[alex77755]

Ещё можно на всякий случай добавить строчки для очистки выделения

W1.Activate
Sheets(1).Select
    Columns("A:A").Interior.Pattern = xlNone ' добавить
LR1 = W1.ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
M1 = Range(Cells(1, 1), Cells(LR1, 1)).Value
W2.Activate
Sheets(1).Select
    Columns("A:A").Interior.Pattern = xlNone' добавить

[alex77755]

Добавил и подсчёт повторов на 2 листе. На 1 оказались все уникальные.
5 сек работает код

Sub QWERTY()
Dim W1 As Workbook
Dim W2 As Workbook
Set W1 = Application.Workbooks("1.xlsm")
Set W2 = Application.Workbooks("2.xlsm")
Dim M1()
Dim M2()
Dim R()
ReDim R(1 To 4, 0)
R(1, 0) = "Файл 1"
R(2, 0) = "Файл 2"
R(3, 0) = "Значение"
R(4, 0) =  "№ Дубля в 2""
Dim t
t = Time
Dim LR1
Dim LR2

Dim Dict As Object
Dim Dict2 As Object
Set Dict = CreateObject("Scripting.Dictionary")
Set Dict2 = CreateObject("Scripting.Dictionary")
W1.Activate
Sheets(1).Select
    Columns("A:A").Interior.Pattern = xlNone
LR1 = W1.ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
M1 = Range(Cells(1, 1), Cells(LR1, 1)).Value
W2.Activate
Sheets(1).Select
    Columns("A:A").Interior.Pattern = xlNone
LR2 = W2.ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
M2 = Range(Cells(1, 1), Cells(LR2, 1)).Value
'загоняем в словарь первый лист
With Dict
    For i = 1 To UBound(M1)
        If Dict2.Exists(M1(i, 1)) Then
          Dict2.Item(M1(i, 1)) = Dict2.Item(M1(i, 1)) + 1
        End If
    
        If Not .Exists(M1(i, 1)) Then
           .Add M1(i, 1), "A" & i
        End If
    Next i
'ищем совпадения во втором и выделяем цветом
    For i = 1 To UBound(M2)
        If Dict2.Exists(M2(i, 1)) Then
          Dict2.Item(M2(i, 1)) = Dict2.Item(M2(i, 1)) + 1
          Else
          Dict2.Add M2(i, 1), 1
        End If
        
      If .Exists(M2(i, 1)) Then
     Cells(i, 1).Interior.Color = RGB(255, 255, 0)
     ReDim Preserve R(1 To 4, UBound(R, 2) + 1)
      R(1, UBound(R, 2)) = .Item(M2(i, 1))
       R(2, UBound(R, 2)) = "A" & i
        R(3, UBound(R, 2)) = M2(i, 1)
        R(4, UBound(R, 2)) = Dict2.Item(M2(i, 1))
      End If
    Next i
End With

Dict.RemoveAll
W1.Activate
'загоняем в словарь второй лист
With Dict
    For i = 1 To UBound(M2)
        If Not .Exists(M2(i, 1)) Then
           .Add M2(i, 1), 1
        End If
    Next i
'ищем совпадения в первом и выделяем цветом
    For i = 1 To UBound(M1)
      If .Exists(M1(i, 1)) Then
      Cells(i, 1).Interior.Color = RGB(255, 255, 0)
      End If
    Next i
End With
Sheets(2).Select
Cells.ClearContents
Sheets(2).Cells.Cells.ClearContents
Range("A1:D" & UBound(R, 2)).Value = Application.Transpose(R)
MsgBox Format(Time - t, "hh:nn:ss")
End Sub