SEARCH COPY AND LINK THE RESULT

[Megharbel]

this code will search for the exact match through the entire workbook (A:O) "some editing might be needed for wider ranges" , make a copy of the raw with the match, and add a link to the matched cell.




Option Explicit
Option Compare Text '< ignore case
'
Sub SearchSheets()
'
Dim FirstAddress As String, WhatFor As String
Dim Cell As Range, Sheet As Worksheet


'
WhatFor = InputBox("What are you looking for?", "Search Criteria")
If WhatFor = Empty Then Exit Sub
'
For Each Sheet In Sheets
If Sheet.Name <> "SEARCH" Then
With Sheet.Columns("A:O")
Set Cell = .Find(WhatFor, LookIn:=xlValues, lookat:=xlWhole)
If Not Cell Is Nothing Then
FirstAddress = Cell.Address
Do
Cell.EntireRow.Copy _
Destination:=Sheets("SEARCH").Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
Debug.Print
Sheets("SEARCH").Cells(Rows.Count, 1).End(xlUp).Offset(0, 18) = "#'" & Sheet.Name & "'!"
Sheets("SEARCH").Cells(Rows.Count, 1).End(xlUp).Offset(0, 17) = Cell.Address
Range("Q1").Formula = "=CONCATENATE(S1,R1)"
Range("P1").Formula = "=HYPERLINK(Q1)"
Range("B1") = WhatFor
Range("A1") = "Looking for"
Set Cell = .FindNext(Cell)
Dim LastRow As Variant
With Worksheets("SEARCH")
LastRow = .Cells(.Rows.Count, "Q").End(xlUp).Row
.Range("Q" & LastRow).AutoFill Destination:=.Range(.Cells(LastRow + 1, "Q"), .Cells(LastRow, "Q")), Type:=xlFillCopy
End With
With Worksheets("SEARCH")
LastRow = .Cells(.Rows.Count, "P").End(xlUp).Row
.Range("P" & LastRow).AutoFill Destination:=.Range(.Cells(LastRow + 1, "P"), .Cells(LastRow, "P")), Type:=xlFillCopy
End With
Loop Until Cell Is Nothing Or Cell.Address = FirstAddress
End If
End With
End If
Next Sheet
'
Set Cell = Nothing
End Sub