поиск по диапазону и подстановка значения в зависимости от результата

[Propinol]

яблоко | | яблоко | ID1
яблоко | | груша | ID2
яблоко | | слива | ID3
Груша | | абрикос | ID4
Груша | |
Слива | |
Абрикос | |

имеется примерно вот такого вида табличка.

задача состоит в том, чтобы ID объектов (яблоки, груши и т.п.), которые обозначены в 4-м столбце подставить во второй собственно в соответствии с 1м столбцом.


моя идея заключается в следующем макросе (правда это только самое начало), который проходит от первой ячейке к последней, и последовательно сравнивает. но он срабатывает только на 1ю ячейку (что и понятно, только там соответствие), так вот затык в том: как сделать так чтобы при проходе он делал поиск по всему столбцу C и при нахождении вставлял в столбец B айдишник в соответствии со столбцом D

что написал вот (в VBA пока новичок совсем):

 Sub Test1()
     
    Range("A2").Select
     
      Do Until IsEmpty(ActiveCell)
        
         If ActiveCell.Value = ActiveCell.Offset(0, 2) Then

Range("B2") = Range("D2")

         Else
      
End If
         
         ActiveCell.Offset(1, 0).Select
      Loop
   End Sub

[alebed]

Предлагаю поступить так:
Примерно так выглядит таблица в Excel
кол A| кол B| кол C| кол D
1| яблоко | | яблоко | |ID1
2| яблоко | | груша | | ID2
3| яблоко | | слива | |ID3
4| Груша | | абрикос | |ID4
5| Груша | |
6| Слива | |
7| Абрикос| |

Дале сам макрос:
Sub Найти_совпадения()
Dim x As Variant, y As Variant SravnenyeDiap As Variant
Range("A1:A7").Select ' Выделяем диапазон для сравнения
' Назначаем переменной SravnenyeDiap диапазон, с которым нужно сравнить выделенный диапазон.
Set SravnenyeDiap = Range("C1:C5")
' Каждую выделенную ячейку сравниваем с каждой ячейкой из диапазона SravnenyeDiap.
For Each x In Selection
For Each y In SravnenyeDiap
If x = y Then x.Offset(0, 1) = y.Offset(0, 1) ' Устанавливаем значения ID
Next y
Next x
End Sub

[Skif-F]

или так:

Sub Start()  'Пробная процедура'
    Dim a As Range
    Set a = Range("A1:A7") 'Обрабатываемый диапазон'
    Call SearchID(a)
End Sub

Sub SearchID(diap As Range)
    Dim BaseDiap As Range, x As Range, c As Range
    
    Set BaseDiap = Range("C1:C4")  'Диапазон с исходными данными'
    For Each x In diap
        Set c = BaseDiap.Find(What:=x.Value, LookIn:=xlValues)
        If Not (c Is Nothing) Then
            'Если что-то нашли, то копируем значение из соседнего столбца'
            Cells(x.Row, x.Column + 1).Value = Cells(c.Row, c.Column + 1).Value
        End If
    Next x
End Sub

[Propinol]

Спасибо огромное, очень помогло

[Bumek]

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

[Казанский]

> Не оставьте мой вопрос без внимания
Трудно это сделать - нет примера.

[IgorGO]

Аналогично.
внимание уделил. помочь ничем не могу, я знаю VBA, но не знаю какие диапазоны проверять, на предмет чего их проверять, какие ячейки копировать...

[Bumek]

Прикрепил файл, формата XLSM (офис 2007, файл с поддержкой макросов). В книге есть минимум 2 листа, в одном производится расчет, в другом данные. Поиск происходит по гар.№, и если номер в листе ак4 и ТЭП_ак4 совпадает, то макрос должен скопировать значения из ТЭПа(желтые колонки) в ак4(синие колонки). Не могу настроить чтобы макрос цеплялся за диапазон другого листа, и чтобы значения сразу нескольких ячеек копировал.... В идеал еще должен быть второй макрос, который будет проверять гаражные номера на обоих листах, и если какой-то из номеров есть в тэп но нет в ак4, он должен меня оповестить каким-то образом, либо вывести отдельно на лист перечень гаражный, либо во всплывающем окне ошибки указать "Гар № 1234 отсутствует"

[Bumek]

Сегодня нашел на работе неточность в коде... если в обрабатываемом диапазоне находится 40, а в диапазоне с исходными данными 4055, то значение от 4055, он скопирует к 40...Как заменить строку

Set c = BaseDiap.Find(What:=x.Value, LookIn:=xlValues)

чтобы макрос копировал значения только при полном соответствии ячеек

[nilem]

Попробуйте так

Set c = BaseDiap.Find(What:=x.Value, LookIn:=xlValues, LookAt:=xlWhole)