leah
07-26-2006, 06:59 AM
Hi
One last small problem... My macro searches through all the sheets in the workbook looking for a user prompted number. When found it sends all the information for that row to a results page. Some of these rows have hyperlinks and I was wondering if there was anyway to have those hyperlinks available on the results page?
Here is the code that searches the pages... help would be greatly appreciated!!
Public Sub FindAllBuilding(Search As String, Reset As Boolean)
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 FindWorkBook() As String
Dim FindPath() As String
Dim FindText() As Variant
Dim Counter As Long
Dim FirstAddress As String
Dim Path As String
Dim MyResponse As VbMsgBoxResult
If Search = "" Then
Prompt = "What building number would you like?" & vbNewLine & vbNewLine & Path
Title = "Input Building Number"
'Delete default search term if required
Search = InputBox(Prompt, Title, "Enter search term")
If Search = "" Then
GoTo Canceled
End If
End If
Application.DisplayAlerts = False
Application.ScreenUpdating = False
'Save found addresses and text into arrays
On Error Resume Next
Set WB = ActiveWorkbook
If Err = 0 Then
On Error GoTo 0
For Each WS In WB.Worksheets
'Omit results page from search
If WS.Name <> "FindWord" Then
With WS.Columns(6)
Set Cell = .Find(What:=Search, After:=.Cells(.Rows.Count, .Columns.Count) _
, 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 FindWorkBook(1 To Counter)
ReDim Preserve FindPath(1 To Counter)
ReDim Preserve FindText(1 To Counter)
FindCell(Counter) = Cell.Address(False, False)
FindText(Counter) = Cell.EntireRow.Cells(1).Resize(1, 4).Value
FindSheet(Counter) = WS.Name
FindWorkBook(Counter) = WB.Name
FindPath(Counter) = WB.FullName
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
'Response if no text found
If Counter = 0 Then
MsgBox Search & " was not found.", vbInformation, "Zero Results For Search"
Exit Sub
End If
'Create FindWord sheet in does not exist
On Error Resume Next
Sheets("FindWord").Select
If Err <> 0 Then
Debug.Print Err
'error occured so clear it
Err.Clear
Sheets.Add.Name = "FindWord"
Sheets("FindWord").Move After:=Sheets(Sheets.Count)
'Run macro to add code to ThisWorkbook
End If
'Write to FindWord
Range("A13:B65536").ClearContents
'Reset prevents looping of code when sheet changes
If Reset = True Then Range("B11").Value = Search
Range("A:A").ColumnWidth = 14
Range("B:B").ColumnWidth = 25
Range("C:C").ColumnWidth = 15
Range("D:D").ColumnWidth = 72
Range("1:300").EntireRow.AutoFit
For Counter = 1 To UBound(FindCell)
Range("A" & Counter + 12).Resize(1, 4).Value = FindText(Counter)
Next Counter
Sheets("Search Engine").Select
Canceled:
Set WB = Nothing
Set WS = Nothing
Set Cell = Nothing
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
--leah
One last small problem... My macro searches through all the sheets in the workbook looking for a user prompted number. When found it sends all the information for that row to a results page. Some of these rows have hyperlinks and I was wondering if there was anyway to have those hyperlinks available on the results page?
Here is the code that searches the pages... help would be greatly appreciated!!
Public Sub FindAllBuilding(Search As String, Reset As Boolean)
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 FindWorkBook() As String
Dim FindPath() As String
Dim FindText() As Variant
Dim Counter As Long
Dim FirstAddress As String
Dim Path As String
Dim MyResponse As VbMsgBoxResult
If Search = "" Then
Prompt = "What building number would you like?" & vbNewLine & vbNewLine & Path
Title = "Input Building Number"
'Delete default search term if required
Search = InputBox(Prompt, Title, "Enter search term")
If Search = "" Then
GoTo Canceled
End If
End If
Application.DisplayAlerts = False
Application.ScreenUpdating = False
'Save found addresses and text into arrays
On Error Resume Next
Set WB = ActiveWorkbook
If Err = 0 Then
On Error GoTo 0
For Each WS In WB.Worksheets
'Omit results page from search
If WS.Name <> "FindWord" Then
With WS.Columns(6)
Set Cell = .Find(What:=Search, After:=.Cells(.Rows.Count, .Columns.Count) _
, 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 FindWorkBook(1 To Counter)
ReDim Preserve FindPath(1 To Counter)
ReDim Preserve FindText(1 To Counter)
FindCell(Counter) = Cell.Address(False, False)
FindText(Counter) = Cell.EntireRow.Cells(1).Resize(1, 4).Value
FindSheet(Counter) = WS.Name
FindWorkBook(Counter) = WB.Name
FindPath(Counter) = WB.FullName
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
'Response if no text found
If Counter = 0 Then
MsgBox Search & " was not found.", vbInformation, "Zero Results For Search"
Exit Sub
End If
'Create FindWord sheet in does not exist
On Error Resume Next
Sheets("FindWord").Select
If Err <> 0 Then
Debug.Print Err
'error occured so clear it
Err.Clear
Sheets.Add.Name = "FindWord"
Sheets("FindWord").Move After:=Sheets(Sheets.Count)
'Run macro to add code to ThisWorkbook
End If
'Write to FindWord
Range("A13:B65536").ClearContents
'Reset prevents looping of code when sheet changes
If Reset = True Then Range("B11").Value = Search
Range("A:A").ColumnWidth = 14
Range("B:B").ColumnWidth = 25
Range("C:C").ColumnWidth = 15
Range("D:D").ColumnWidth = 72
Range("1:300").EntireRow.AutoFit
For Counter = 1 To UBound(FindCell)
Range("A" & Counter + 12).Resize(1, 4).Value = FindText(Counter)
Next Counter
Sheets("Search Engine").Select
Canceled:
Set WB = Nothing
Set WS = Nothing
Set Cell = Nothing
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
--leah