Макрос для

[Derden]

Всем добрый день!

Подскажите, пожалуйста, возможно ли решение такой проблемы в экселе:

На одном листе находится "статичная база" данных на 1500 строк, в котором есть помимо других данных столбец "фото" с гиперссылками.

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

В этих листах есть три одинаковых столбца.

Моя задача найти в "статичной базе" адрес идентичный адресу в "адресной программе" и скопировать гипперссылку из столбца "фото" в "статичной базе" в столбец "фото" в "адресной программе".

Вся проблема в том, что объём работы стал просто нереальный. Иногда за день приходиться обработать и перенести вручную гипперсылки около 2 000 строк. К концу вечера глаза просто уже ничего не видят и за четыре месяца зрение посадил просто зверски.

На прошлой работе у меня была похожая задача, но там было проще - должны были совпасть только по одной ячейке с адресом, и я автоматизировал с помощью функции "ВПР".
А тут помимо адреса, есть ещё три стороны А, В и С и адрес поэтому разбит на две ячейки. Например
ул. Лесная / А
ул. Лесная / В
ул. Лесная / С

и функция "ВПР" уже не может искать совпадения.

В общем, взываю о помощи. Заранее огромное спасибо за любой совет!

П.С. Пример прикрепил.

[EducatedFool]

Попробуйте такой вариант:



Вот весь код:

Код: Выделить всё

[color=darkblue]Sub[/color] CopyHyperLinks()
    [color=darkblue]On[/color] [color=darkblue]Error[/color] [color=darkblue]Resume[/color] [color=darkblue]Next[/color]
    [color=darkblue]Dim[/color] sh [color=darkblue]As[/color] Worksheet: [color=darkblue]Set[/color] sh = Worksheets("ClearChannel Baltics And Russia")
    [color=darkblue]Dim[/color] cell [color=darkblue]As[/color] Range: Application.ScreenUpdating = [color=darkblue]False[/color]
    [color=darkblue]For[/color] [color=darkblue]Each[/color] cell [color=darkblue]In[/color] Range([c6], Range("c" & Rows.Count).End(xlUp)).Cells
        [color=darkblue]If[/color] Len(Trim(cell)) [color=darkblue]Then[/color]
            sh.Range("c:c").Find(cell).Offset(, 1).Resize(3).Find(cell.Next).EntireRow.Cells(2).Copy cell.Previous
        [color=darkblue]End[/color] [color=darkblue]If[/color]
    [color=darkblue]Next[/color] cell: Application.ScreenUpdating = [color=darkblue]True[/color]
[color=darkblue]End[/color] [color=darkblue]Sub[/color]

[color=darkblue]Sub[/color] ClearRange()
    Range([b6], Range("b" & Rows.Count).End(xlUp)).ClearContents
End Sub

[Derden]

EducatedFool, спасибо Вам огромное!

Всё работает просто отлично. Уже попробовал на нескольких программах.

Вы просто не представляете, как Вы мне помогли. Низко, низко Вам кланяюсь.

До сих пор не верю, что мне больше не придётся проводить десятки часов нажимая в десятитысячный раз ctrl+v, сtrl+v и уходить работы с покрасневшими глазами.

Ещё раз огромное-огромное спасибо. Всех Вам благ!