Hyperlink naar tabblad

[Terhoeven]

Goedenavond forumleden,
Onderstaand prog. maakt een nieuw tabblad van de ingevoerde naam. tevens wordt de naam in het werkblad Relatie aangevuld.
Is het ook mogelijk om aan de ingevulde naam in het werkblad Relatie een hyperlink te koppelen naar het nieuw aangemaakte tabblad.

Private Sub Worksheet_Change(ByVal Target As Range)
  If Target.Address(0, 0) <> "F6" Then Exit Sub
  If IsError(Evaluate("'" & Target.Value & "'!A1")) Then
      Sheets("sjabloon").Copy , Sheets(Sheets.Count)
      ActiveSheet.Name = Target
      
     End If
      
      With ActiveSheet.Tab
      .Color = 255
      End With
      
  Sheets("1VGO").Cells(Rows.Count, 1).End(xlUp).Offset(1) = Target
      Sheets("Relaties").Cells(Rows.Count, 1).End(xlUp).Offset(1) = Target

"hier VBA om hyperlink aan te maken"

Groet René

 

[edmoor]

Plaats een voorbeeld document.

 

[Terhoeven]

Bij deze

 

[edmoor]

Maak er eens dit van:

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Address(0, 0) <> "F3" Then Exit Sub
    If IsError(Evaluate("'" & Target.Value & "'!A1")) Then
        Sheets("sjabloon").Copy , Sheets(Sheets.Count)
        ActiveSheet.Name = Target
    End If
      
    ActiveSheet.Tab.Color = 255
     
    With Sheets("invoer")
        .Hyperlinks.Add _
        Anchor:=Range(.Cells(Rows.Count, 1).End(xlUp).Offset(1).Address), _
        Address:=Range(.Cells(Rows.Count, 1).End(xlUp).Offset(1).Address), _
        SubAddress:="'" & Target & "'!A1", _
        TextToDisplay:=Target.Value
    End With
    
    Sheets("relatie").Cells(Rows.Count, 1).End(xlUp).Offset(1) = Target
End Sub

 

[HSV]

Of:

Private Sub Worksheet_Change(ByVal Target As Range)
 If Target.Address(0, 0) = "F3" and target <> "" Then
  Application.EnableEvents = False
   If IsError(Evaluate("'" & Target.Value & "'!A1")) Then
      Sheets("sjabloon").Copy , Sheets(Sheets.Count)
      With ActiveSheet
         .Name = Target
         .Tab.Color = 255
      End With
    Hyperlinks.Add Cells(Rows.Count, 1).End(xlUp).Offset(1), "", "'" & Target & "'!a1", , Target.Value
   End If
  Application.EnableEvents = True
 End If
End Sub

 

[Terhoeven]

Edmoor en HSV
Dit werkt uitstekend. Echter wat ik vergeten ben is dat dit ook in het tabblad relaties moet gebeuren. Dus zowel bij invoer als bij relaties.
Groet René

 

[edmoor]

Je hebt nu gezien wat de bedoeling is

 

[Terhoeven]

Hmm gaat nog niet geheel naar wens. Zie bestandje.

 

[HSV]

Private Sub Worksheet_Change(ByVal Target As Range)
 If Target.Address(0, 0) = "F3" And Target <> "" Then
  Application.EnableEvents = False
   If IsError(Evaluate("'" & Target.Value & "'!A1")) Then
      Sheets("sjabloon").Copy , Sheets(Sheets.Count)
      With ActiveSheet
         .Name = Target
         .Tab.Color = 255
      End With
    Hyperlinks.Add Cells(Rows.Count, 1).End(xlUp).Offset(1), "", "'" & Target & "'!a1", , Target.Value
[COLOR=#0000ff]    Hyperlinks.Add sheets("relatie").Cells(Rows.Count, 1).End(xlUp).Offset(1), "", "'" & Target & "'!a1", , Target.Value[/COLOR]
   End If
  Application.EnableEvents = True
 End If
End Sub

 

[Terhoeven]

Harry fantastisch. Precies wat ik bedoelde. Ik ben jullie zeer erkentelijk.
Groetn oet Twente
René