Looking to create a macro which will automatically reference a specific cell (different worksheet), instead of manually changing the cell reference and linking one by one. For example, user will click on "TB" (1st image), this will take them to the Fines cell in TB worksheet (2nd image).

Tried the below, however saying invalid call or argument I can see RDRef is empty and no value is assigned to it, not sure why.

Sub Hyperlink()

Dim reference As Range
Dim TBRef As Variant
Dim RDDef As Variant

x = 2
y = 2

Worksheets("Queries").Select

    For Each reference In Range("B3:B7").Cells
        If reference = "TB" Then
            TBRef = Worksheets("TB").Cells(x, "A").Value
            ActiveCell.Hyperlinks.Add Anchor:=reference, Address:="", SubAddress:=TBRef, TextToDisplay:="TB"
        Else
            RDRef = Worksheets("R&D Schedule").Cells(y, "A").Value
            ActiveCell.Hyperlinks.Add Anchor:=reference, Address:="", SubAddress:=RDRef, TextToDisplay:="R&D"
    
        End If
x = x   1
y = y   1
    Next reference
End Sub

Expecting: User clicks on TB for Fines, this will take them to worksheet TB cell Fines. Macro will automatically create the links from each cell in Queries to the specific cell in different worksheet

CodePudding user response：

SubAddress has to be passed as address - not the value of the cell. And you have to look for the cell on the target sheet to get the address.

That's what the function getAddressOfCell returns.

Sub addHyperlink()

Dim wsQueries As Worksheet
Set wsQueries = ThisWorkbook.Worksheets("Queries")

Dim rgType As Range
Set rgType = wsQueries.Range("B2:B6")

Dim subAddress As String
Dim reference As Range

For Each reference In rgType.Cells
    subAddress = getAddressOfCell(reference.Offset(, -1), _
        ThisWorkbook.Worksheets(reference.Value).Cells(1, 1).CurrentRegion)
    If subAddress <> vbNullString Then
        wsQueries.Hyperlinks.Add anchor:=reference, Address:="", subAddress:=subAddress ', TextToDisplay:=reference.Value
    End If
Next reference
End Sub

Private Function getAddressOfCell(strFind As String, rgSearchIn As Range) As String
Dim rgFound As Range
With rgSearchIn 
    Set rgFound = .Find(what:=strFind)
    If Not rgFound Is Nothing Then
        getAddressOfCell = rgFound.Address(True, True, , True)
    End If
End With
End Function

CodePudding user response：

Add Hyperlinks

Option Explicit

Sub AddHyperlinksToQueries()

    Dim sNames(): sNames = VBA.Array("TB", "RD Schedule")
    Dim sAddresses(): sAddresses = VBA.Array("A2", "A2")
    
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    Dim dws As Worksheet: Set dws = wb.Sheets("Queries")
    Dim drg As Range
    Set drg = dws.Range("B3", dws.Cells(dws.Rows.Count, "B").End(xlUp))
    
    Dim dCell As Range, sIndex, sName As String, sAddress As String
    
    For Each dCell In drg.Cells
        sName = CStr(dCell.Value)
        sIndex = Application.Match(sName, sNames, 0)
        If IsNumeric(sIndex) Then ' 'sIndex' is one-based...
            sIndex = sIndex - 1 ' ... the arrays are zero-based
            sName = sNames(sIndex)
            sAddress = sAddresses(sIndex)
            dCell.Hyperlinks.Add Anchor:=dCell, Address:="", _
                SubAddress:="'" & sName & "'!" & sAddress, TextToDisplay:=sName
            sAddresses(sIndex) = dws.Range(sAddress).Offset(1).Address(0, 0)
        Else ' not in array
            dCell.Clear
        End If
    Next dCell
        
    MsgBox "Hyperlinks created.", vbInformation
        
End Sub