Vert. zoek en Hyperlink overnemen

[erwin87]

Beste,

graag zou ik verticaal zoeken en als waarde de Hyperlink krijgen.
is dit mogelijk?
zie voorbeeld bestandje
in de gele cel van het eerste Tabblad zou ik de hyperlink van de gele cel op het 2de tabblad krijgen.

alvast bedankt..Bekijk bijlage TEST What if.xlsb

 

[HSV]

In B16 van het eerste blad.

=ALS(ISLEEG($B12);"";HYPERLINK("#'"&VERT.ZOEKEN($B12;keuzelijsten!$D$1:$F$50;KOLOM();0)&"'!$A$1";VERT.ZOEKEN($B12;keuzelijsten!$D$1:$F$50;KOLOM();0)))

 

[MarcelBeug]

Een formule oplossing werkt alleen als de hyperlink met de formule kan worden gereconstrueerd.
Als je écht de hyperlink van de betreffende cel wilt ophalen, dan ben je op VBA aangewezen, zoals bijvoorbeeld in de bijlage met

Sub getHyperlink()
    
    On Error Resume Next
    
    With Worksheets("registratielijst")
        .Hyperlinks.Add _
            anchor:=Range("B16"), _
            Address:="#" & Worksheets("keuzelijsten").Range("D:D"). _
            Find(.Range("B12"), Worksheets("keuzelijsten").Range("D1")).Offset(0, 1).Hyperlinks(1).SubAddress
    End With
    
    On Error GoTo 0

End Sub

Als test heb ik hyperlink aangepast naar cel A3 van 'PDL Issue'.

 

[MarcelBeug]

Ik ben er nog even verder mee gegaan en heb nu een oplossing die reageert op wijziging van cel B12 en dan automatisch de hyperlink in B16 toevoegt of verwijdert.
Bij het verwijderen van een hyperlink wordt ook het formaat van de cel gewijzigd; daarom kopieert de code het formaat van de samengevoegde B12:C12 naar B16.

Private Sub Worksheet_Change(ByVal Target As Range)

Dim crntCell As Range

If Intersect(Target, Range("B12")) Is Nothing Then Exit Sub

Set crntCell = ActiveCell

On Error GoTo removeHyperlink
    
    With Worksheets("registratielijst")
        .Hyperlinks.Add _
            anchor:=Range("B16"), _
            Address:="#" & Worksheets("keuzelijsten").Range("D:D"). _
            Find(.Range("B12"), Worksheets("keuzelijsten").Range("D1")).Offset(0, 1).Hyperlinks(1).SubAddress
    End With
    
    Exit Sub
    
removeHyperlink:
    Application.ScreenUpdating = False
    With Worksheets("Registratielijst")
        If .Range("B16").Hyperlinks.Count > 0 Then
            .Range("B16").Hyperlinks(1).Delete
            .Range("B12:C12").Copy
            .Range("B16").PasteSpecial xlFormats
            Application.CutCopyMode = False
        End If
    End With
    crntCell.Activate
    Application.ScreenUpdating = True

End Sub

 

[erwin87]

Werkt perfect bedankt allen.

werkt perfect bedankt voor de snelle reactie's...