Search keyword from invitation in Excel then create new tab with summary part 2
This question is about generating some code developed by Romcel Geluz found here
- The supplied code somehow creates duplicate entries on the newly created sheet with the found search text. How does each found row element from each sheet appear only once when the keyword is found?
- How to add columns of found rows to the created sheet, for example:
- What is the name of the newly created sheet, "Summary" and placed as the first sheet?
The initial data in the sheets looks like this:
Thanks for your help and time.
Here is the code:
Private Sub FindAndCreateReport()
' 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.Add
Set rCellwsReport = wsReport.Cells(1, 1)
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)
' 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
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
source to share
How does each found row element from each sheet appear only once when the keyword is found?
starting the next search on the next line in the loop Do ... Loop Until rFound.Address = rFirstCell.Address
How to add columns of found rows to the created sheet, for example:
by assigning values to the current row starting at the column C
like in the code below
What is the name of the newly created sheet, "Summary" and placed as the first sheet?
using parameter before
and property .Name
.
Set wsReport = ThisWorkbook.Sheets.Add(before:= ThisWorkbook.Sheets(1))
wsRTeport.Name = "Summary"
You will find more details in the highlighted sections of the modified code below. As an aside, I removed rLastCell
and search from the last cell, it doesn't make sense in the code. rFirstCell
can also be uninstalled as soon as you confirm that these changes are what you are looking for.
Private Sub FindAndCreateReport()
' Declare variables we will use to loop through each worksheet
Dim eWs As Worksheet, rFound As Range, 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
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Create the report sheet at first position then name it "Summary"
Dim wsReport As Worksheet, rCellwsReport As Range
Set wsReport = ThisWorkbook.Sheets.Add(Before:=ThisWorkbook.Sheets(1))
wsReport.name = "Summary"
Set rCellwsReport = wsReport.Cells(1, 1)
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'On Error Resume Next '<-- Probably not necessary
' Start looping through this workbook
For Each eWs In ThisWorkbook.Worksheets
If eWs.name = wsReport.name Then GoTo NextSheet '<~ skip report sheet
Set rFound = eWs.UsedRange.Find(what:=strLookFor, LookIn:=xlValues)
If rFound Is Nothing Then GoTo NextSheet
Set rFirstCell = rFound
Do
WriteDetails rCellwsReport, rFound
'Since we found a match on this row, we start our next search on next row
Set rFound = eWs.UsedRange.Find(what:=strLookFor, _
after:=eWs.Cells(rFound.row + 1, eWs.UsedRange.Column), LookIn:=xlValues)
Loop Until rFound.Address = rFirstCell.Address '<~ loop to find other matches
NextSheet:
Next
End Sub
Private Sub WriteDetails(ByRef rReceiver As Range, ByRef rDonor As Range)
rReceiver.Value = rDonor.Parent.name
rReceiver.Offset(, 1).Value = rDonor.Address
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Copy the row of the Donor to the receiver starting from column C.
' Since you want to preserve formats, we use the .Copy method
rDonor.EntireRow.Resize(, 100).Copy rReceiver.Offset(, 2)
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Set rReceiver = rReceiver.Offset(1)
End Sub
source to share