Vlookup with Hyperlink - VBA

Question

В настоящее время я пытаюсь найти способ скопировать и вставить ссылку гиперссылки с другого листа.

Путь программа должна работать в том, что вы выбираете из списка категорию элемента, а затем все последующие столбцы автоматически заполняются ВПР проверка на «» Категория «» Лист

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

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

Sub Update() 
Dim calData As String 
Dim add As String 
Dim i, LastRow 
LastRow = Range("G" & Rows.Count).End(xlUp).Row 
For i = 3 To LastRow 
If Cells(i, "G").Value <> "" Then 
    Range("Q" & i).Value = Application.VLookup(Cells(i, "G"), Sheets("Category").Range("A2:H60"), 4, False) 
    Range("R" & i).Value = Application.VLookup(Cells(i, "G"), Sheets("Category").Range("A2:H60"), 6, False) 
    'Set calData = Worksheets("Calendar").Range("R" & i) 
    'add = "G:\Engineering\Engineering trainees (HUG)\Etalonnage\Procédures calibration\" & Data 
     'With Worksheets("Calendar") 
     '.Hyperlinks.add Anchor:=.Range("R" & i), _ 
     'Address:=add, _ 
     'TextToDisplay:=Data 
     'End With 
    Range("S" & i).Value = Application.VLookup(Cells(i, "G"), Sheets("Category").Range("A2:H60"), 7, False) 
    Range("T" & i).Value = Application.VLookup(Cells(i, "G"), Sheets("Category").Range("A2:H60"), 8, False) 
End If 
End Sub 

Answer 1

Я думаю, вы близки. Попробуйте ввести код ниже.
Обратите внимание, как правило, не используйте «добавить» в качестве имени переменной. Он перепутал IntelliSense, я изменился на addr.
Не лучше ли столбцы Q, R, S, T с Формулой вместо фиксированного значения? Если у вас нет кода события для вызова этого Sub, когда ячейки в столбце G изменены.

Sub Update() 
    Dim calData As String 
    Dim addr As String 
    Dim i As Long, LastRow As Long 

    LastRow = Range("G" & Rows.Count).End(xlUp).Row 
    For i = 3 To LastRow 
     If Cells(i, "G").Value <> "" Then 
      Range("Q" & i).Value = Application.VLookup(Cells(i, "G"), Sheets("Category").Range("A2:H60"), 4, False) 
      Range("R" & i).Value = Application.VLookup(Cells(i, "G"), Sheets("Category").Range("A2:H60"), 6, False) 

      calData = Worksheets("Calendar").Range("R" & i).Value ' Or .Text, depends on data 
      addr = "G:\Engineering\Engineering trainees (HUG)\Etalonnage\Procédures calibration\" & calData 
      With Worksheets("Calendar") 
       .Hyperlinks.Add Anchor:=.Range("R" & i), Address:=addr, TextToDisplay:=calData 
      End With 

      Range("S" & i).Value = Application.VLookup(Cells(i, "G"), Sheets("Category").Range("A2:H60"), 7, False) 
      Range("T" & i).Value = Application.VLookup(Cells(i, "G"), Sheets("Category").Range("A2:H60"), 8, False) 
     End If 
    Next 
End Sub