Домашняя страница Undo Do New Save Карта сайта Обратная связь Поиск по форуму
МИР MS EXCEL - Гость.xls

Вход

Регистрация

Напомнить пароль

 

= Мир MS Excel/Сопоставление данных и гиперссылок - Мир MS Excel

Регистрация · Логин: · Пароль: · · Забыли пароль?
Страница 1 из 11
Модератор форума: _Boroda_, Pelena, Manyasha, SLAVICK 
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Сопоставление данных и гиперссылок (Макросы/Sub)
Сопоставление данных и гиперссылок
sergeis88 Дата: Среда, 31.08.2016, 16:12 | Сообщение № 1
Группа: Пользователи
Ранг: Прохожий
Сообщений: 6
Репутация: 0 ±
Замечаний: 0% ±

Excel 2010
Добрый день.
Столкнулся с проблемой, суть которой в следующем:
На листе 1 есть гиперссылки на интернет сайты в столбце А и им соответствуют коды в столбце В, а на втором листе в столбце А названия аналоги, а в столбце В те же самые коды в другом порядке.
Необходим макрос, который притянет гиперссылки столбца А первого листа в Столбец А второго листа, соответственно кодам столбцов В.
Буду рад идеям, которые дадут направление для решения данного вопроса.
(пример во вложении, итоговый результат представлен на третьем листе)
К сообщению приложен файл: 4949778.xlsx(11Kb)
 
Ответить
СообщениеДобрый день.
Столкнулся с проблемой, суть которой в следующем:
На листе 1 есть гиперссылки на интернет сайты в столбце А и им соответствуют коды в столбце В, а на втором листе в столбце А названия аналоги, а в столбце В те же самые коды в другом порядке.
Необходим макрос, который притянет гиперссылки столбца А первого листа в Столбец А второго листа, соответственно кодам столбцов В.
Буду рад идеям, которые дадут направление для решения данного вопроса.
(пример во вложении, итоговый результат представлен на третьем листе)

Автор - sergeis88
Дата добавления - 31.08.2016 в 16:12
devilkurs Дата: Среда, 31.08.2016, 17:27 | Сообщение № 2
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 167
Репутация: 43 ±
Замечаний: 0% ±

Excel 2007, 2010
При условии что обе таблицы начинаются с A1
[vba]
Код

Sub devilkurs()
    Dim Arr(), Arr2(), iR%, iR2%, sURL As String, Sh, Sh2
    Set Sh = ThisWorkbook.Sheets("Лист1")
    Set Sh2 = Sheets("Лист2")
    Arr = Sh.Range(Sh.Cells(2, 1), Sh.Cells(Sh.Cells(Sh.Rows.Count, 2).End(xlUp).Row, 2)).Value
    Arr2 = Sh2.Range(Sh2.Cells(2, 1), Sh2.Cells(Sh2.Cells(Sh2.Rows.Count, 2).End(xlUp).Row, 2)).Value
    
    For iR2 = 2 To UBound(Arr2, 1) + 1
        For iR = 2 To UBound(Arr, 1) + 1
            If Arr2(iR2 - 1, 2) = Arr(iR - 1, 2) Then
                If Sh.Cells(iR, 1).Hyperlinks.Count > 0 Then
                sURL = Sh.Cells(iR, 1).Hyperlinks(1).Address
                Sh2.Hyperlinks.Add Anchor:=Sh2.Cells(iR2, 1), Address:= _
                    sURL, TextToDisplay:=Sh.Cells(iR2, 1).Value
                End If
            End If
        Next
    Next
    
End Sub
[/vba]
К сообщению приложен файл: 2878045.xlsm(20Kb)


 
Ответить
СообщениеПри условии что обе таблицы начинаются с A1
[vba]
Код

Sub devilkurs()
    Dim Arr(), Arr2(), iR%, iR2%, sURL As String, Sh, Sh2
    Set Sh = ThisWorkbook.Sheets("Лист1")
    Set Sh2 = Sheets("Лист2")
    Arr = Sh.Range(Sh.Cells(2, 1), Sh.Cells(Sh.Cells(Sh.Rows.Count, 2).End(xlUp).Row, 2)).Value
    Arr2 = Sh2.Range(Sh2.Cells(2, 1), Sh2.Cells(Sh2.Cells(Sh2.Rows.Count, 2).End(xlUp).Row, 2)).Value
    
    For iR2 = 2 To UBound(Arr2, 1) + 1
        For iR = 2 To UBound(Arr, 1) + 1
            If Arr2(iR2 - 1, 2) = Arr(iR - 1, 2) Then
                If Sh.Cells(iR, 1).Hyperlinks.Count > 0 Then
                sURL = Sh.Cells(iR, 1).Hyperlinks(1).Address
                Sh2.Hyperlinks.Add Anchor:=Sh2.Cells(iR2, 1), Address:= _
                    sURL, TextToDisplay:=Sh.Cells(iR2, 1).Value
                End If
            End If
        Next
    Next
    
End Sub
[/vba]

Автор - devilkurs
Дата добавления - 31.08.2016 в 17:27
Manyasha Дата: Среда, 31.08.2016, 17:34 | Сообщение № 3
Группа: Модераторы
Ранг: Старожил
Сообщений: 1997
Репутация: 829 ±
Замечаний: 0% ±

Excel 2010, 2016
еще один вариант:
[vba]
Код
Sub addHyperlinks()
    Dim sh1 As Worksheet, sh2 As Worksheet
    Dim i As Long, r As Long, link As String, lr As Long
    Set sh1 = ThisWorkbook.Sheets(1)
    Set sh2 = ThisWorkbook.Sheets(2)
    With sh2
        lr = .Cells(Rows.Count, 1).End(xlUp).Row
        .Cells(3, 1).Resize(lr - 2).Hyperlinks.Delete
        On Error Resume Next
        For i = 3 To lr
            r = 0
            r = WorksheetFunction.Match(.Cells(i, 2), sh1.Columns("b:b"), 0)
            If r Then
                link = sh1.Cells(r, 1).Hyperlinks(1).Address
                .Cells(i, 1).Hyperlinks.Add Anchor:=.Cells(i, 1), Address:=link
            End If
        Next i
    End With
End Sub
[/vba]
К сообщению приложен файл: 4949778-1.xlsm(20Kb)


marinamorozova_box@mail.ru
ЯД: 410013299366744 WM: R193491431804
 
Ответить
Сообщениееще один вариант:
[vba]
Код
Sub addHyperlinks()
    Dim sh1 As Worksheet, sh2 As Worksheet
    Dim i As Long, r As Long, link As String, lr As Long
    Set sh1 = ThisWorkbook.Sheets(1)
    Set sh2 = ThisWorkbook.Sheets(2)
    With sh2
        lr = .Cells(Rows.Count, 1).End(xlUp).Row
        .Cells(3, 1).Resize(lr - 2).Hyperlinks.Delete
        On Error Resume Next
        For i = 3 To lr
            r = 0
            r = WorksheetFunction.Match(.Cells(i, 2), sh1.Columns("b:b"), 0)
            If r Then
                link = sh1.Cells(r, 1).Hyperlinks(1).Address
                .Cells(i, 1).Hyperlinks.Add Anchor:=.Cells(i, 1), Address:=link
            End If
        Next i
    End With
End Sub
[/vba]

Автор - Manyasha
Дата добавления - 31.08.2016 в 17:34
sergeis88 Дата: Среда, 31.08.2016, 17:38 | Сообщение № 4
Группа: Пользователи
Ранг: Прохожий
Сообщений: 6
Репутация: 0 ±
Замечаний: 0% ±

Excel 2010
Идеальный код. specool


Сообщение отредактировал sergeis88 - Среда, 31.08.2016, 18:22
 
Ответить
СообщениеИдеальный код. specool

Автор - sergeis88
Дата добавления - 31.08.2016 в 17:38
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Сопоставление данных и гиперссылок (Макросы/Sub)
Страница 1 из 11
Поиск:

Яндекс цитирования
© 2010-2017 · Дизайн: MichaelCH · Хостинг от uCoz · При использовании материалов сайта, ссылка на www.excelworld.ru обязательна!