Макрос для

Весь MS Office, программирование на Visual Basic for Applications и MS VB

Модератор: Naeel Maqsudov

Ответить
Derden
Сообщения: 2
Зарегистрирован: 19 авг 2009, 17:00

Макрос для

Сообщение Derden » 09 сен 2009, 14:12

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

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

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

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

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

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

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

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

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

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

П.С. Пример прикрепил.
У вас нет необходимых прав для просмотра вложений в этом сообщении.

Аватара пользователя
EducatedFool
Сообщения: 196
Зарегистрирован: 06 апр 2008, 13:03
Откуда: Россия, Урал
Контактная информация:

Re: Макрос для

Сообщение EducatedFool » 09 сен 2009, 14:48

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

Изображение

Вот весь код:

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

[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
Макросы для Excel, Word, CorelDRAW. Быстро, профессионально, недорого. http://ExcelVBA.ru/

Благодарности принимаются на кошелёк WebMoney: R318574877619 и Яндекс.Деньги: 41001335672216

Derden
Сообщения: 2
Зарегистрирован: 19 авг 2009, 17:00

Re: Макрос для

Сообщение Derden » 09 сен 2009, 15:42

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

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

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

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

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

Ответить