Copiar Celda con Hipervínculo Microsoft Excel VBA
Necesito crear un buscador con Macros (VBA Excel), el cual me permita ingresar un "TAG" en una celda, y me entregue la información de todos los atributos que contenga dicho "TAG" basado en una lista de datos. Cabe destacar que la búsqueda se realiza en todas las Hojas de Cálculo que contenga el Libro, dado a que los "TAG" están clasificados en ellas.
Realicé el código siguiente en VBA el cual me es útil y me entrega la información según el "TAG" ingresado, pero uno de los atributos ("Layout") es un hipervínculo, el cual lamentablemente sólo me lo copia como texto, y no como hipervínculo. Lo que más necesito es que me entregue en la Hoja (Buscar) el hipervínculo.
El código que realicé es el siguiente, agradezco vuestra ayuda.
VBA Hoja 1 (Buscar)
Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) If Intersect([Codigo], Target) Is Nothing Then Exit Sub If Not [bAuto] Then Exit Sub Buscar End Sub
VBA Módulo 1
Option Explicit Sub Buscar() Dim WS As Worksheet Dim rBingo As Range Borrar_Form For Each WS In ThisWorkbook.Worksheets If WS.Name Like "FZ*" Then Set rBingo = WS.Cells.Find(what:=[Codigo], lookat:=xlWhole) If Not rBingo Is Nothing Then Exit For End If Next WS If rBingo Is Nothing Then ' No encontrado MsgBox "Código " & [Codigo] & " no encontrado", vbInformation, "AM Consultores" Else Copiar_datos WS, rBingo.Row End If End Sub Sub Borrar_Form() Dim rCell As Range Set rCell = [Datos] Do While rCell <> "" rCell.Offset(0, 1).Value = "" Set rCell = rCell.Offset(1, 0) Loop [Nota].Value = "" End Sub Sub Copiar_datos(ByRef queWS As Worksheet, ByVal queFila As Long) Dim rCell As Range Set rCell = [Datos] On Error Resume Next Do While rCell <> "" rCell.Offset(0, 1) = queWS.Cells(queFila, queWS.Rows(1).Find(rCell.Value).Column) Set rCell = rCell.Offset(1, 0) Loop On Error GoTo 0 [Nota].Value = "El dato está en la hoja " & queWS.Name & ", en la fila " & Format(queFila, "#,##0") End Sub
Esta es la planilla, no la pude adjuntar:

