Thanks for the help,
In the end I used the following to resolve the problems
Set Found = .Range("B3:B1000").Find(what:=myText, LookIn:=xlValues, LookAt:=xlPart, MatchCase:=False)
and
Worksheets(ws.Name).Range("B2:L2").Copy
Worksheets("instructions").Range("B" & 17 + foundNum).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
this will now only search the cells required and paste the headers for each sheet at the top of rows of data returned from each sheet
searches multiple sheets eccept selected ones, returns the row data for each found value, creates a hyperlink for that row and puts it at the start of the row. it also creates a header row for each sheet were search was found (sample shown using test data prior to implementation)
Sheet & Location Generic ID Storage Location Storage Type
Resistors $B$10 10000.00
Resistors $B$12 100000.00
Resistors $B$13 1000.00
Resistors $B$16 100.00
Sheet & Location Generic ID Storage Location Storage Type
Capacitors $B$4 100
Capacitors $B$6 1000
full button code for anyone interested
Code:
Dim ws As Worksheet, Found As Range
Dim myText As String, FirstAddress As String
Dim AddressStr As String, foundNum As Integer
myText = Worksheets("instructions").Range("G6")
If myText = "" Then Exit Sub
Worksheets("instructions").Range("A16:XX200").Delete
For Each ws In ThisWorkbook.Worksheets
With ws
If ws.Name = "Instructions" Or ws.Name = "Storage Locations" Then GoTo myNext
t = ws.Name
Set Found = .Range("B3:B1000").Find(what:=myText, LookIn:=xlValues, LookAt:=xlPart, MatchCase:=False)
If Not Found Is Nothing Then
If Not foundNum > 1 Then
Worksheets("instructions").Range("A17").Value = "Sheet & Location"
Worksheets(ws.Name).Range("B2:L2").Copy
Worksheets("instructions").Range("B17").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Else
foundNum = foundNum + 1
Worksheets("instructions").Range("A" & 17 + foundNum).Value = "Sheet & Location"
Worksheets(ws.Name).Range("B2:L2").Copy
Worksheets("instructions").Range("B" & 17 + foundNum).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
End If
FirstAddress = Found.Address
Do
foundNum = foundNum + 1
AddressStr = .Name & " " & Found.Address & vbCrLf
addr = Found.Address
Set Found = .Range("B3:B1000").FindNext(Found)
A = Mid(Found.FindNext.Address, 4, 4)
Aa = "$B$"
ab = Aa & A
row18 = foundNum + 17
Found.EntireRow.Copy Destination:=Worksheets("instructions").Range("A" & row18)
Worksheets("instructions").Range("Z100") = AddressStr
Range("Z100").Copy
Range("A" & row18).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
tt = ws.Name
ActiveSheet.Hyperlinks.Add _
Anchor:=Worksheets("instructions").Range("A" & row18), _
Address:="", _
SubAddress:=ws.Name + "!" + addr, _
TextToDisplay:=AddressStr
Range("A" & row18).Select
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
Loop While Not Found Is Nothing And Found.Address <> FirstAddress
End If
myNext:
End With
Next ws
If Len(AddressStr) Then
Else:
MsgBox "Unable to find " & myText & " in this workbook.", vbExclamation
End If
End Sub