Hyperlink query

[mdmackillop]

In the attached file, the search (enter search term in cell B1 on FindWord)creates hyperlinks to the found cells, the hyperlinks fail, however, if there is a bracket in the sheet name. Is there a way around this?

[xCav8r]

Don't you need to surround the sheet with single quotation marks when it has spaces? (Maybe that's a stupid question.)

PS. I changed the third sheet's name to BoQ2 and the links work with that.

[Bob Phillips]

In the attached file, the search (enter search term in cell B1 on FindWord)creates hyperlinks to the found cells, the hyperlinks fail, however, if there is a bracket in the sheet name. Is there a way around this?

It's the space in the sheet name MD. Tryt this alternate

Option Compare Text
Option Explicit

Public Sub FindAll(Search As String)
Dim WB              As Workbook
    Dim WS              As Worksheet
    Dim Cell            As Range
    Dim Prompt          As String
    Dim Title           As String
    Dim FindCell()      As String
    Dim FindSheet()     As String
    Dim FindLink()      As String
    Dim FindText()      As String
    Dim Counter         As Long
    Dim FirstAddress    As String
    Dim MyResponse      As VbMsgBoxResult
    Dim Exists          As Boolean
    Dim k               As Long
'Cancel events
    Application.EnableEvents = False
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
'Loop through sheets; add location and text to array
    On Error Resume Next
    Set WB = ActiveWorkbook
    If Err = 0 Then
        On Error GoTo 0
        For Each WS In WB.Worksheets
            If WS.Name <> "FindWord" Then
                With WB.Sheets(WS.Name).Range("D:D")
                    Set Cell = .Find(What:=Search, LookIn:=xlValues, LookAt:=xlPart, _
                        MatchCase:=False, SearchOrder:=xlByColumns)
                    If Not Cell Is Nothing Then
                        FirstAddress = Cell.Address
                        Do
                            Counter = Counter + 1
                            ReDim Preserve FindCell(1 To Counter)
                            ReDim Preserve FindSheet(1 To Counter)
                            ReDim Preserve FindText(1 To Counter)
                            ReDim Preserve FindLink(1 To Counter)
                            FindCell(Counter) = Cell.Address(False, False)
                            FindText(Counter) = Cell.Text
                            FindSheet(Counter) = WS.Name
                            If InStr(1, WS.Name, " ") > 0 Then
                                FindLink(Counter) = "'" & WS.Name & "'"
                            Else
                                FindLink(Counter) = WS.Name
                            End If
                            Set Cell = .FindNext(Cell)
                        Loop While Not Cell Is Nothing And Cell.Address <> FirstAddress
                    End If
                End With
            End If
        Next
    End If
    On Error GoTo 0
'Exit if nothing found
    If Counter = 0 Then
        MsgBox Search & " was not found.", vbInformation, "Zero Results For Search"
        GoTo Cancelled
    End If
'Write found data to sheet
    On Error Resume Next
    Sheets("FindWord").Select
    Range("A3:H65536").ClearContents
    For Counter = 1 To UBound(FindCell)
        ActiveSheet.Hyperlinks.Add Anchor:=Range("A" & Counter + 2), _
            Address:="", SubAddress:=FindLink(Counter) & "!" & FindCell(Counter), _
            TextToDisplay:=FindSheet(Counter) & "!" & FindCell(Counter)
            Range("B" & Counter + 2).Value = FindText(Counter)
        'Add data from rows
        For k = 3 To 8
            Cells(Counter + 2, k).Formula = Sheets(FindSheet(Counter)) _
                    .Range(FindCell(Counter)).Offset(0, k - 2).Value
        Next k
    Next Counter
'Clear variables and reset events
Cancelled:
    Set WB = Nothing
    Set WS = Nothing
    Set Cell = Nothing
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    Application.EnableEvents = True
End Sub

[Bob Phillips]

ACtually, less changes

Option Compare Text
Option Explicit

Public Sub FindAll(Search As String)
Dim WB              As Workbook
    Dim WS              As Worksheet
    Dim Cell            As Range
    Dim Prompt          As String
    Dim Title           As String
    Dim FindCell()      As String
    Dim FindSheet()     As String
    Dim FindText()      As String
    Dim Counter         As Long
    Dim FirstAddress    As String
    Dim MyResponse      As VbMsgBoxResult
    Dim Exists          As Boolean
    Dim k               As Long
'Cancel events
    Application.EnableEvents = False
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
'Loop through sheets; add location and text to array
    On Error Resume Next
    Set WB = ActiveWorkbook
    If Err = 0 Then
        On Error GoTo 0
        For Each WS In WB.Worksheets
            If WS.Name <> "FindWord" Then
                With WB.Sheets(WS.Name).Range("D:D")
                    Set Cell = .Find(What:=Search, LookIn:=xlValues, LookAt:=xlPart, _
                        MatchCase:=False, SearchOrder:=xlByColumns)
                    If Not Cell Is Nothing Then
                        FirstAddress = Cell.Address
                        Do
                            Counter = Counter + 1
                            ReDim Preserve FindCell(1 To Counter)
                            ReDim Preserve FindSheet(1 To Counter)
                            ReDim Preserve FindText(1 To Counter)
                            FindCell(Counter) = Cell.Address(False, False)
                            FindText(Counter) = Cell.Text
                            FindSheet(Counter) = WS.Name
                            Set Cell = .FindNext(Cell)
                        Loop While Not Cell Is Nothing And Cell.Address <> FirstAddress
                    End If
                End With
            End If
        Next
    End If
    On Error GoTo 0
'Exit if nothing found
    If Counter = 0 Then
        MsgBox Search & " was not found.", vbInformation, "Zero Results For Search"
        GoTo Cancelled
    End If
'Write found data to sheet
    On Error Resume Next
    Sheets("FindWord").Select
    Range("A3:H65536").ClearContents
    For Counter = 1 To UBound(FindCell)
        ActiveSheet.Hyperlinks.Add Anchor:=Range("A" & Counter + 2), _
                                   Address:="", _
                                   SubAddress:="'" & FindSheet(Counter) & "'!" & FindCell(Counter), _
                                   TextToDisplay:=FindSheet(Counter) & "!" & FindCell(Counter)
        Range("B" & Counter + 2).Value = FindText(Counter)
        'Add data from rows
        For k = 3 To 8
            Cells(Counter + 2, k).Formula = Sheets(FindSheet(Counter)) _
                    .Range(FindCell(Counter)).Offset(0, k - 2).Value
        Next k
    Next Counter
'Clear variables and reset events
Cancelled:
    Set WB = Nothing
    Set WS = Nothing
    Set Cell = Nothing
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    Application.EnableEvents = True
End Sub

[xCav8r]

Maybe my suggestion...err...question...wasn't so stupid?

[Bob Phillips]

Maybe my suggestion...err...question...wasn't so stupid?

No, spot-on!

I had already posted before I saw it.

[sheeeng]

xld, I tried your code already..
sad to say I cannot get it work....

[Bob Phillips]

xld, I tried your code already..
sad to say I cannot get it work....

You need MD's worrkbook event code as well to fire it.

[mdmackillop]

Thanks all.
Sometimes you're just "too close" to see the simple problem!
Regards
Malcolm