I have created a function that makes the selected cell to a hyperlink to a sheet in my excel with the same name. That is, if my cell says "Test", the text will become a link to the sheet with the name "Test", if this sheet exists. I would like the function to be executed for all the cells in column A from A7 down to the last cell with a value instead of just the one cell. I can't figure out how to change my code in order to do so. Please help! My code is the following:

Sub CreateHyperlinkToSheet()
    Dim selectedCell As Range
    Set selectedCell = Selection

    selectedCell.Hyperlinks.Add Anchor:=selectedCell, Address:="#'" & selectedCell.Value & "'!A1", TextToDisplay:="" & selectedCell.Value & ""

End Sub

Function SheetExists(sheetName As String) As Boolean
    On Error Resume Next
    SheetExists = (Len(Sheets(sheetName).Name) > 0)
    On Error GoTo 0
End Function

I can only make the function work for the selected cell and not for many cells at the same time.

I have created a function that makes the selected cell to a hyperlink to a sheet in my excel with the same name. That is, if my cell says "Test", the text will become a link to the sheet with the name "Test", if this sheet exists. I would like the function to be executed for all the cells in column A from A7 down to the last cell with a value instead of just the one cell. I can't figure out how to change my code in order to do so. Please help! My code is the following:

Sub CreateHyperlinkToSheet()
    Dim selectedCell As Range
    Set selectedCell = Selection

    selectedCell.Hyperlinks.Add Anchor:=selectedCell, Address:="#'" & selectedCell.Value & "'!A1", TextToDisplay:="" & selectedCell.Value & ""

End Sub

Function SheetExists(sheetName As String) As Boolean
    On Error Resume Next
    SheetExists = (Len(Sheets(sheetName).Name) > 0)
    On Error GoTo 0
End Function

I can only make the function work for the selected cell and not for many cells at the same time.

• excel
• vba

3 Answers 3

If you're ok with selecting the cells before running the code, consider the following where you use a For Each-loop:

Sub CreateHyperlinkToSheet()
    Dim selectedCell As Range
    For Each selectedCell in Selection

        selectedCell.Hyperlinks.Add Anchor:=selectedCell, Address:="#'" & selectedCell.Value & "'!A1", TextToDisplay:="" & selectedCell.Value & ""

    Next

End Sub

Sub GenerateSheetHyperlinks()
    Dim srcSheet As Worksheet
    Dim lastRow As Long
    Dim currentCell As Range
    Dim targetSheetName As String

    ' Use the active worksheet as the source.
    Set srcSheet = ActiveSheet

    ' Identify the last non-empty cell in column A.
    lastRow = srcSheet.Cells(srcSheet.Rows.Count, "A").End(xlUp).Row

    ' Loop through cells in column A starting from row 7.
    For Each currentCell In srcSheet.Range("A7:A" & lastRow)
        targetSheetName = Trim(CStr(currentCell.Value))
        
        ' Proceed if the cell contains text and a corresponding worksheet exists.
        If Len(targetSheetName) > 0 Then
            If WorksheetExists(targetSheetName) Then
                ' Delete any existing hyperlinks to avoid duplicates.
                If currentCell.Hyperlinks.Count > 0 Then
                    currentCell.Hyperlinks.Delete
                End If
                
                ' Create a hyperlink that navigates to cell A1 of the corresponding worksheet.
                currentCell.Hyperlinks.Add Anchor:=currentCell, _
                                           Address:="#'" & targetSheetName & "'!A1", _
                                           TextToDisplay:=targetSheetName
            End If
        End If
    Next currentCell
End Sub

' Returns True if a worksheet with the given name exists in the workbook.
Function WorksheetExists(wsName As String) As Boolean
    Dim ws As Worksheet
    WorksheetExists = False
    For Each ws In ThisWorkbook.Worksheets
        If StrComp(ws.Name, wsName, vbTextCompare) = 0 Then
            WorksheetExists = True
            Exit For
        End If
    Next ws
End Function

Replace List of Worksheet Names with Hyperlinks

Sub GenerateSheetHyperlinks()
    
    ' Define constants.
    Const SRC_SHEET_NAME As String = "Sheet1" ' adjust
    Const SRC_FIRST_CELL_ADDRESS As String = "A7"
    
    ' Reference the workbook.
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    ' Reference the source worksheet.
    Dim sws As Worksheet: Set sws = wb.Sheets(SRC_SHEET_NAME) ' adjust!
    
    ' Reference the source range, the single-column range
    ' containing the sheet names.
    Dim srg As Range, RowsCount As Long:
    With sws.Range(SRC_FIRST_CELL_ADDRESS)
        RowsCount = sws.Cells(sws.Rows.Count, "A").End(xlUp).Row - .Row + 1
        If RowsCount < 1 Then Exit Sub ' no data
        Set srg = .Resize(RowsCount)
    End With
    
    ' Delete existing hyperlinks.
    srg.Hyperlinks.Delete
    
    ' Declare additional variables.
    Dim dws As Worksheet, cell As Range, Value As Variant, SheetName As String
    
    ' Add hyperlinks to cells with names of existing worksheets.
    For Each cell In srg.Cells
        Set dws = Nothing ' reset worksheet variable
        Value = cell.Value ' read the cell value
        If Not IsError(Value) Then ' check if no error
            SheetName = CStr(Value) ' convert value to string
            On Error Resume Next ' prevent error if worksheet doesn't exist
                Set dws = wb.Sheets(SheetName) ' attempt to reference
            On Error GoTo 0 ' reenable error trapping
        End If
        If Not dws Is Nothing Then ' worksheet exists
            SheetName = dws.Name ' to correct the case
            cell.Hyperlinks.Add _
                Anchor:=cell, _
                Address:="#'" & SheetName & "'!A1", _
                TextToDisplay:=SheetName ' 'TextToDisplay' must be a string
        'Else ' worksheet doesn't exist; do nothing
        End If
    Next cell
    
    ' Inform.
    MsgBox "Hyperlinks to worksheets regenerated.", vbInformation

End Sub