Hyperlink kopieren

[Terhoeven]

Goedemiddag forumleden,
In het bijgevoegde bestandje is in werkblad Relaties een tabel aangemaakt. Deze zijn voorzien van een hyperl. welke verwijst naar Relatie A>E.
In de tabbladen A>E kan d.m.v. een voorkeuzelijst gekozen worden waarmee gekozen Relatie een Relatie heeft.
Echter neemt de voorkeuzelijst niet de hyperl. over. Is dit te realiseren met VBA.
Groet René

 

[AlexCEL]

Echter neemt de voorkeuzelijst niet de hyperl. over.

is het de bedoeling dat B6 in elk 'relatie' tabblad ook een hyperlink wordt?

 

[Terhoeven]

Inderdaad en indien eer meerdere relaties zijn deze ook in B7 etc.

 

[jkpieterse]

Met een relatie naam in cel B6:

=HYPERLNK("'#"&B6&"'!A1";"Ga naar relatie")

 

[Terhoeven]

Goedemorgen,

Vooralsnog werkt dit niet. Indien naam uit voorkeuzelijst wordt gekozen en in het desbetreffende werkblad in cel B6 wordt geplaatst dient deze ook een hyperlink te worden naar het tabblad van deze relatie. Zie tekst in nieuwe bijlage.
Groet René

 

[jkpieterse]

Werkt prima, maar je moet niet verwachten dat het in dezelfde cel kan.

 

[Terhoeven]

Inderdaad werkt prima. Echter is dit niet mogelijk om dit via VBA wel in de cel voor elkaar te krijgen.
Gr. René

 

[Terhoeven]

Onderstaande code komt in de buurt maar werkt niet naar behoren.

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

If Target.Address(0, 0) = "B6" And Target <> "" Then
Application.EnableEvents = False


Hyperlinks.Add Cells(Rows.Count, 2).End(xlUp).Offset(1), "", "'" & Target & "'!b6", , Target.Value


Application.EnableEvents = True
End If
End Sub

 

[jkpieterse]

Alles kan, maar een formule is veel simpeler te onderhouden.

 

[Terhoeven]

Gaat nog niet naar behoren

Goedemiddag leden,

Het wil nog niet lukken. Weet iemand hoe dit op te lossen in VBA.
Gr. René

 

[HSV]

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
 If Target.Address = "$B$6" Then Sh.Hyperlinks.Add Target, "", "'" & Target & "'!a1", , Target.Value
End Sub

 

[VenA]

met een kleine uitbreiding.

In de module van Thisworkbook en de rest weggooien.

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
  If Not Intersect(Target, Sh.Columns(2).SpecialCells(-4174)) Is Nothing And Target.Count = 1 Then
    If Target.Value <> "" Then Sh.Hyperlinks.Add Target, "", "'" & Target & "'!a1", , Target.Value
  End If
End Sub

 

[Terhoeven]

Hartelijk dank leden,

De laatste oplossing is geweldig. Nogmaals mijn dank
Groet René

 

[Terhoeven]

Vraagje nog wat precies de specials cells -4174 inhoud.
gr René

 

[VenA]

Gebruik de <F1> toetst dan kom je in de help van Microsoft.

xlCellTypeAllValidation -4174 Cells having validation criteria.

 

[jkpieterse]

Het ontgaat mij waarom je het getal gebruikt en niet gewoon xlCellTypeAllValidation, dat zegt toch meer dan -4147?

 

[Terhoeven]

Goedeavond VenA
De door jou aangereikte oplossing werkt prima. Echter bij het toepassen kreeg ik een foutmelding indien in het werkblad waar geen gegevensvalidatie
van toepassing is. Dit heb ik opgelost door in 1 cel in kolom 2 toch een gegevensvalidatie toe te voegen. (deze heeft verder geen functie)
Nogmaals dank voor de oplossing.
Groet René

 

[VenA]

Als je weet wat een foutmelding veroorzaakt, dan kan je het ook zo doen

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
  On Error Resume Next
  If Not Intersect(Target, Sh.Columns(2).SpecialCells(-4174)) Is Nothing And Target.Count = 1 Then
    If Target.Value <> "" Then Sh.Hyperlinks.Add Target, "", "'" & Target & "'!a1", , Target.Value
  End If
End Sub

In jouw voorbeeldbestand is dit beter

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
  If Sh.Name <> "Relaties" Then
    If Not Intersect(Target, Sh.Columns(2).SpecialCells(-4174)) Is Nothing And Target.Count = 1 Then
      If Target.Value <> "" Then Sh.Hyperlinks.Add Target, "", "'" & Target & "'!a1", , Target.Value
    End If
  End If
End Sub

On Error Resume Next alleen bewust gebruiken omdat het alle fouten onderdrukt.

 

[Terhoeven]

Dit werkt. Foutmelding is" Kan geen cellen vinden"
Daar in enkele tabbladen geen gegevensvalidatie in kolom twee van toepassing is.