PDA

View Full Version : Hyperlink query



mdmackillop
07-06-2005, 02:49 PM
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
07-06-2005, 03:35 PM
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.

xld
07-06-2005, 03:37 PM
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

xld
07-06-2005, 03:41 PM
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
07-06-2005, 03:43 PM
Maybe my suggestion...err...question...wasn't so stupid? :)

xld
07-06-2005, 04:06 PM
Maybe my suggestion...err...question...wasn't so stupid? :)

No, spot-on!

I had already posted before I saw it.

sheeeng
07-06-2005, 06:58 PM
:( xld, I tried your code already..
sad to say I cannot get it work....

xld
07-07-2005, 12:09 AM
:( 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
07-07-2005, 03:42 AM
Thanks all.
Sometimes you're just "too close" to see the simple problem!
Regards
Malcolm