Need to find and collect all cells with a certain word onto a shee

[Guest]

Hi there,

I'm new to macros. Could anyone help me with a macro to search for the word
'warranty' on all the sheets and collect all the cells with the word
'warranty' onto a new sheet.

I'm struggling to do this. It sounds very difficult to too.

Any help greatly appreciated

Thanks

Suzanne

 

[Guest]

You could try something like this. I don't have time to add the sheet or put
it on the sheet. I'm sure someone else can do that for you.

Sub FindWarranty()

Dim WS As Worksheet
Dim myRange As Range
Dim myNewRange As Range


For Each WS In ActiveWorkbook.Worksheets
Set myNewRange = WS.Cells(1, 1)
Do
Set myRange = myNewRange
Set myNewRange = WS.Cells.Find(What:="Warranty", After:=myRange,
LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByColumns,
SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If myRange.Address <> myNewRange.Address Then
Debug.Print WS.Name, myNewRange.Address, myNewRange.Value
End If
Loop While myRange.Address <> myNewRange.Address
Next WS


End Sub

 

[Guest]

This macro records results in a worksheet called "new sheet". It scans thru
all cells in all worksheets looking for the keyword. If a keyword is found
the sheetname, the cell address, and the cell contents are recorded back in
new sheet:

Sub collect_um()
Set nsh = Worksheets("new sheet")
k = 1
For Each sh In Worksheets
If sh.Name <> "new sheet" Then
For Each r In sh.UsedRange
If Application.WorksheetFunction.IsText(r) Then
If Len(r.Value) <> Len(Replace(r.Value, "warranty", "")) Then
nsh.Cells(k, 1).Value = sh.Name
nsh.Cells(k, 2).Value = r.Address
nsh.Cells(k, 3).Value = r.Value
k = k + 1
End If
End If
Next
End If
Next
End Sub

 

[Guest]

Hi Gary,

Thanks it works

I added the two following lines to create the sheet otherwise I understand
that I need to have a sheet already existing before I ran.

Sheets.Add
ActiveSheet.Name = "new sheet"

Thanks again

 

[Guest]

Thanks Barb,

I had a play with this and I see it prints what I want to the Immediates
windows.
Thanks to both you and Gary for the help that I needed.