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:AD10000").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"
tbl_start = Worksheets("instructions").Range("A" & 17 + foundNum).Address
rr1 = Found.Row
trng = Range(tbl_start, "A" & 17 + foundNum).Address
Worksheets(ws.Name).Range("B2:AA2").Copy
Worksheets("instructions").Range("B17").Select
Else
foundNum = foundNum + 1
Worksheets("instructions").Range("A" & 17 + foundNum).Value = "Sheet & Location"
tbl_start = Worksheets("instructions").Range("A" & 17 + foundNum).Address
rr1 = Found.Row
trng = Range(tbl_start, "A" & 17 + foundNum).Address
Worksheets(ws.Name).Range("B2:AA2").Copy
Worksheets("instructions").Range("B" & 17 + foundNum).Select
End If
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
FirstAddress = Found.Address
Do
foundNum = foundNum + 1
AddressStr = .Name & " " & Found.Address & vbCrLf
addr = Found.Address
Set Found = .Range("B3:AD10000").FindNext(Found)
r1 = Found.Row
ttt = rr1
ll = Len(r1)
trng = Range("A18:A" & 17 + foundNum - 1).Address
ttt = Split(trng, "$")(2)
If WorksheetFunction.CountIf(Range(trng), r1) = 0 Then
g = 1
Else
g = 2
End If
row18 = foundNum + 17
Found.EntireRow.Copy Destination:=Worksheets("instructions").Range("A" & row18)
Worksheets("instructions").Range("AA1") = AddressStr
Range("AA1").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
Loop While Not Found Is Nothing And Found.Address <> FirstAddress
End If
If Not Found Is Nothing Then
foundNum = foundNum + 1
ActiveSheet.ListObjects.Add(xlSrcRange, Range(tbl_start & ":$AA$" & row18), , xlYes).Name = "Table" & foundNum
End If
myNext:
End With
Next ws