Code that can report out same fields as the Excel Find and Replace tool.

[atf32]

I have a need for vba Code that will list out all cells that match specified string in a workbook. Like when I use the "Find and Replace" tool in Excel. However, I need the code so that I can save out the report. Can someone please help with some code?

 

[Worf]

Try this:

Sub FindString()
Dim rep As Worksheet, sh As Worksheet, i%, r As Range, fa$
Set rep = Sheets("sheet2")                                      ' report sheet
rep.[a:c].ClearContents
i = 1
For Each sh In ActiveWorkbook.Worksheets
    If sh.Name <> "Sheet2" Then
        Set r = sh.UsedRange.Find("gold", , xlValues, xlPart)
        If Not r Is Nothing Then
            fa = r.Address
            Do
                Set r = sh.UsedRange.FindNext(r)
                rep.Cells(i, 1) = r.Parent.Name                 ' sheet name
                rep.Cells(i, 2) = r.Address                     ' cell address
                rep.Cells(i, 3) = r                             ' cell value
                If r.Parent.Name = "Sheet2" Then Exit Sub       ' safety net
                i = i + 1
            Loop While Not r Is Nothing And r.Address <> fa
        End If
    End If
Next
End Sub

 

[portews]

I think Worf and I are on the same wavelength, I just added a few more bells and whistles.
Enter the string to search for in an infobox, select Whole cell or Partial in the Messagebox. It will check for a Summary sheet and add one if necessary. It will give you a message if no match found.

Sub FindAll()
'http://www.mrexcel.com/forum/excel-questions/959624-code-can-report-out-same-fields-excel-find-replace-tool.html
Dim Sh As Worksheet
Dim summmary As Worksheet
Dim Loc As Range
Dim searchMethod As Integer


'get the string to find
FindThis = InputBox("Enter Text to Find", "Find All Matches")
'if Cancel button, end
If FindThis = "" Then Exit Sub


'Whole or Part Cell match?
searchMethod = MsgBox("Match Whole Field?" & vbNewLine & "(Yes for Whole, No for Partial Field)", 3, "Match Type")
'2=Cancel, 6=Yes, 7=No
If searchMethod = 2 Then Exit Sub


'test to see if there is a Summary sheet
Set summary = Nothing
On Error Resume Next
Set summary = Sheets("Summary")
On Error GoTo 0
'if there is a Summary sheet
If Not summary Is Nothing Then
    'clear contents
    summary.Cells.ClearContents
Else
    'create a new "Summary" sheet
    ActiveWorkbook.Sheets.Add.Name = "Summary"
    Set summary = Worksheets("Summary")
End If


'set title row on Summary sheet
summary.Range("A1") = "String to Find: " & Chr(34) & FindThis & Chr(34)
summary.Range("B1") = "Worksheet"
summary.Range("C1") = "Cells"


'go thru each worksheet
For Each Sh In ThisWorkbook.Worksheets
    'if you're on Summary, skip this sheet
    If Sh.Name = "Summary" Then GoTo skipSummary
    With Sh.UsedRange
        'look for the text string
        Set Loc = .Find(what:=FindThis, _
            LookAt:=searchMethod - 5, SearchOrder:=xlByRows)
        'if you find a match
        If Not Loc Is Nothing Then
            'record the first location
            firstaddress = Loc.Address
            Do
                'find the last row in the Summary sheet
                Lastrow = summary.Cells(summary.Rows.Count, "A").End(xlUp).Row
                'add the values
                Cells(Lastrow + 1, 1) = Loc.Value
                Cells(Lastrow + 1, 2) = Sh.Name
                summary.Hyperlinks.Add Anchor:=Cells(Lastrow + 1, 3), Address:="", _
                    SubAddress:=Sh.Name & "!" & Loc.Address, TextToDisplay:=Loc.Address
                
                'find next
                Set Loc = .FindNext(Loc)
            Loop While Loc.Address <> firstaddress
            Else
                'count the number of not founds
                nf = nf + 1
        End If
    End With
    Set Loc = Nothing
skipSummary:
Next
'if the not found count matches the number of worksheets -1
If nf = ThisWorkbook.Sheets.Count - 1 Then
    'print "No matches found"
    summary.Cells(2, 1) = "No matches found"
End If
End Sub

 

[atf32]

Thanks you both for the code. Sorry that I did not see these earlier. Hopefully one or both will work.

Cool exercise.