Поиск и копирование диапазона

[Wind-up Bird]

Здравствуйте. В написании макросов делаю первые шаги. Столкнулся с проблемой в написании скрипта:

Sub Test()


     Dim CompareRange As Range, OriginalRange As Range, x As Variant, y As Variant
    Set OriginalRange = Range([E5], Range("E" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeConstants)
    Set CompareRange = Workbooks("Áàçà.xlsx").Worksheets(1).Range("B2:B300")
    
    For Each x In OriginalRange.Cells
    x.Offset(0, 10) = x.Offset(0, -3)
    For Each y In CompareRange
       If x = y Then x.Offset(0, 11) = y.Offset(0, 2)
 

            
Next y
    Next x


End Sub

Поиск работает отлично находит нужные ячейки. Но не получается сделать так чтобы копировались смежные ячейки рядом с найденной
(x.Offset(0, -3),y.Offset(0,3),y.Offset(0,4), y.Offset(0,5)) на другой лист

[EducatedFool]

Код-то исправить и ускорить не проблема, вот только не понял одного:

идёт цикл For Each y In CompareRange
если нашли совпадение - копируем данные в определённую ячейку OriginalRange
с этим всё понятно, но:
если в CompareRange найдено НЕСКОЛЬКО совпадений, то код будет записывать данные из следующих совпадений поверх уже записанных данных

Так и надо? или совпадений несколько быть не может?

строка (x.Offset(0, -3),y.Offset(0,3),y.Offset(0,4), y.Offset(0,5)) вообще не понятна...

И ещё - надо копировать ячейки вместе с форматированием, или только значения?

Попробуйте такой код (копирование вместе с форматированием ячеек):

Sub Test()
    Dim CompareRange As Range, OriginalRange As Range
    Set OriginalRange = Range([E5], Range("E" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeConstants)
    Set CompareRange = Workbooks("Aaca.xlsx").Worksheets(1).Range("B2:B300")

    On Error Resume Next    ' чтобы при отсутствии совпадений не вылетала ошибка
    For Each x In OriginalRange.Cells
        x.Offset(0, 10) = x.Offset(0, -3)
        
        ' производим поиск в CompareRange, от найденного значения отступаем вправо на 2 ячейки,
        ' расширяем диапазон вправо до 4 ячеек, и копируем эти 4 ячейки в строку в OriginalRange
        CompareRange.Find(x, , xlValues, xlWhole).Offset(, 2).Resize(, 4).Copy x.Offset(, 11)
    Next x
End Sub

Или такой - копируются только значения:

Sub Test()
    Dim CompareRange As Range, OriginalRange As Range, x As Range
    Set OriginalRange = Range([E5], Range("E" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeConstants)
    Set CompareRange = Workbooks("Aaca.xlsx").Worksheets(1).Range("B2:B300")

    On Error Resume Next    ' чтобы при отсутствии совпадений не вылетала ошибка
    For Each x In OriginalRange.Cells
        x.Offset(0, 10) = x.Offset(0, -3)

        ' производим поиск в CompareRange, от найденного значения отступаем вправо на 2 ячейки,
        ' расширяем диапазон вправо до 4 ячеек, и копируем эти 4 ячейки в строку в OriginalRange
        x.Offset(, 11).Resize(, 4).Value = CompareRange.Find(x, , xlValues, xlWhole).Offset(, 2).Resize(, 4).Value
    Next x
End Sub

[Wind-up Bird]

если в CompareRange найдено НЕСКОЛЬКО совпадений, то код будет записывать данные из следующих совпадений поверх уже записанных данных

Так и надо? или совпадений несколько быть не может?

Совпадение несколько быть не может..

строка (x.Offset(0, -3),y.Offset(0,3),y.Offset(0,4), y.Offset(0,5)) вообще не понятна...

Это какие ячейки мне нужны. нужно скопировать определенные ячейки.

[Wind-up Bird]

Спасибо Получилось.