Search keyword from invitation in Excel then create a new tab with summary
I have an excel file with many sheets (tabs). I wanted to create a script in excel, so that when you hit run, a prompt appears asking "Text to search", then after typing the text "fail", for example the script then searches through each sheet. A pivot sheet is then created that contains rows of cells from various tabs from the text search.
Thank you for your help.
+1
source to share
1 answer
Here you go, paste this into a normal module,
Private Sub FindAndPasteToReport()
' Declare variables we will use to loop through each worksheet
Dim eWs As Worksheet
Dim rFound As Range
' Declare variables to check if we are done looping through the worksheet
Dim rLastCell As Range
Dim rFirstCell As Range
' Declare and prepare the variable to hold the string we are looking for
Dim strLookFor As String
strLookFor = InputBox("Text to Search for")
If Len(Trim(strLookFor)) = 0 Then Exit Sub
' Declare and prepare variables used when creating the report
Dim rCellwsReport As Range
Dim wsReport As Worksheet
Set wsReport = ThisWorkbook.Sheets("receiver") '<~ you need to declare the sheet that will receive the report.
With wsReport
Set rCellwsReport = .Cells(1, .Columns.Count).End(xlToLeft).Offset(0, 2)
rCellwsReport.Value = strLookFor
Set rCellwsReport = rCellwsReport.Offset(1, 0)
End With
On Error Resume Next '<~ skip all errors encountered
' Start looping through this workbook
For Each eWs In ThisWorkbook.Worksheets
If eWs.Name = wsReport.Name Then GoTo NextSheet '<~ skip if we are checking the report sheet
With eWs.UsedRange
' Set the lastcell. So we can start the search from the bottom.
Set rLastCell = .Cells(.Cells.Rows.Count)
' Initial search for the string.
Set rFound = .Find(what:=strLookFor, after:=rLastCell)
End With
If Not rFound Is Nothing Then '<~ if we found something then?
' Set it as the first find.
Set rFirstCell = rFound
' Write its details to the report through this small sub.
WriteDetails rCellwsReport, rFound
End If
Do
' Continue looking for more matches
Set rFound = eWs.UsedRange.Find(what:=strLookFor, after:=rFound)
' Checks and exits the loop if the current cell is the same as the 1st cell
If rFound.Address = rFirstCell.Address Then Exit Do
' If there are matches, write them down the report sheet.
WriteDetails rCellwsReport, rFound
Loop Until rFound.Address = rFirstCell.Address '<~ loop through until the current cell is the first cell
NextSheet:
Next
End Sub
along with this code.
Private Sub WriteDetails(ByRef rReceiver As Range, ByRef rDonor As Range)
rReceiver.Value = rDonor.Parent.Name
rReceiver.Offset(, 1).Value = rDonor.Address
Set rReceiver = rReceiver.Offset(1, 0)
End Sub
Now this will not generate a report, you need to first create a worksheet that will receive all the texts. You need to update the line Set wsReport = ThisWorkbook.Sheets("receiver")
according to your needs.
+1
source to share