Страницы: 1
RSS
Макрос сравнения двух списков на разных листах в одной книге
 
Добрый вечер.
Подскажите, пожалуйста, что не так в макросе.
Задача следующая на двух листах размещены списки ИНН. Необходимо их сравнить и цветом выделить дубликаты.
Размеры списков на обеих листах будут меняться.
Нашел на просторах интернет и адаптировал под себя следующий макрос
Код
Sub Сoincidence()
Dim ws1 As Worksheet: Set ws1 = ThisWorkbook.Sheets("Лист1")
Dim ws2 As Worksheet: Set ws2 = ThisWorkbook.Sheets("Лист2")
Dim Numbers1, Numbers2, i
Dim Found As Range

Numbers1 = ws1.Range("B2:B" & ws1.Range("B" & ws1.Rows.Count).End(xlUp).Row).Value
Numbers2 = ws2.Range("В2:В" & ws2.Range("B" & ws2.Rows.Count).End(xlUp).Row).Value

For i = LBound(Numbers2, 1) To UBound(Numbers2, 1)
    Set Found = ws1.Range("B2:B").Find(Numbers2(i, 1))
        If Not Found Is Nothing Then
            Found.Interior.Color = vbYellow
        End If
    Set Found = Nothing
Next i

For i = LBound(Numbers1, 1) To UBound(Numbers1, 1)
    Set Found = ws2.Range("В2:В").Find(Numbers1(i, 1))
        If Not Found Is Nothing Then
            Found.Interior.Color = vbYellow
        End If
    Set Found = Nothing
Next i

End Sub
Но при запуске вот здесь
Код
Dim ws2 As Worksheet: Set ws2 = ThisWorkbook.Sheets("Лист2")
выскакивает ошибка: Subscript out of range
Что не так и почему для ws1 она не появляеться?

Во вложении файл с примером.
Небольшое дополнение. На листе 1 будет большая таблица и список ИНН будет именно в столбце В и начинаться будет со второй строчки.
На листе 2 список можно поместить в любое место
Изменено: D P - 09.01.2022 22:32:24
 
ThisWorkbook - книга с запускаемым макросом. Возможно, в ней нет листа Лист2 и вообще нужных данных. Можно попробовать все ThisWorkbook переделать на ActiveWorkbook или указать конкретно Workbooks("test.xlsx").
 
Код
Set Found = ws1.Range("B2:B" & ws2.Cells(ws2.Rows.Count, "B").End(xlUp).Row).Find(Numbers2(i, 1))

Замените русские В на латинские B
 
Kuzmich, там все В латинские. Перепроверил. Ошибка все равно вылазит.

tolikt, лист2 есть, проверил и данные в нем тоже есть.
Цитата
Можно попробовать все ThisWorkbook переделать на ActiveWorkbook
Замена ThisWorkbook на ActiveWorkbook дает другую ошибку: Metod 'Range of object'_Worksheet' failed
и в другом месте
Код
Set Found = ws1.Range("B2:B").Find(Numbers2(i, 1))
 
Код
Sub Сoincidence()
    Dim ws1 As Worksheet, ws2 As Worksheet
    Dim Numbers1 As Variant, Numbers2 As Variant, i As Long
    Dim Found As Range
 
    Set ws1 = ThisWorkbook.Sheets("Лист1")
    Set ws2 = ThisWorkbook.Sheets("Лист2")
    
    'снимаем выделения в столбцах В
    ws1.Columns(2).Interior.Color = xlNone
    ws2.Columns(2).Interior.Color = xlNone
    
    Numbers1 = ws1.Range("B2:B" & ws1.Range("B" & ws1.Rows.Count).End(xlUp).Row).Value
    Numbers2 = ws2.Range("B2:B" & ws2.Range("B" & ws2.Rows.Count).End(xlUp).Row).Value
 
    For i = LBound(Numbers2, 1) To UBound(Numbers2, 1)
        Set Found = ws1.Range("B:B").Find(Numbers2(i, 1))
        If Not Found Is Nothing Then
            Found.Interior.Color = vbYellow
        End If
        Set Found = Nothing
    Next i
 
    For i = LBound(Numbers1, 1) To UBound(Numbers1, 1)
        Set Found = ws2.Range("B:B").Find(Numbers1(i, 1))
        If Not Found Is Nothing Then
            Found.Interior.Color = vbYellow
        End If
        Set Found = Nothing
    Next i
    MsgBox "Конец", vbInformation, ""
End Sub
 
New, , та же ошибка и по сути в том же месте
Код
    Set ws2 = ThisWorkbook.Sheets("Лист2")
Изменено: D P - 09.01.2022 22:51:36
 
Вы сообщение 3 смотрели?
Где в вашем примере макрос?
 
Kuzmich, сообщение видел и на него ответил, у меня не сохранилось при ответе ссылка на того, кому отвечал.
Пример поменял, макрос в нем присутствует.
Изменено: D P - 09.01.2022 22:48:26
 
1 Кое где В написаны русскими
2 Строки 11 и 19 Range("В2:В") надо заменить Range("В:В")
Изменено: Евгений Смирнов - 10.01.2022 06:12:14
 
Добрый день! А почему эту задачу нельзя решить через ВПР?
 
Евгений Смирнов, спасибо работает. Вроде проверял все В.

Luna2903, нет нельзя. На первом листе будет большая таблица и там неудобно формулу протягивать.
Изменено: D P - 10.01.2022 13:16:59
Страницы: 1
Наверх