excel - 根据 Excel 中的提示搜索关键字，然后创建包含摘要第 2 部分的新选项卡

Question

这个问题是构建 Romcel Geluz found here 开发的代码

• 附加的代码以某种方式在新创建的工作表中使用找到的搜索文本创建了重复条目。如何让每个工作表中的每个找到的行条目在找到关键字时仅出现一次？
• 如何将找到的行列附加到创建的工作表中，如下所示:

• 如何将新创建的工作表命名为“Summary”并放置为第一个工作表？

工作表中的原始数据如下所示:

感谢您的帮助和时间。

这是代码:

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

Answer 1

How to have each found row entry from each sheet to appear just once when the keyword is found?

通过在循环的下一行开始下一个搜索Do ... Loop Until rFound.Address = rFirstCell.Address

How to also append the found row columns to the created sheet, like this:

通过将值分配给从列 C 开始的当前行，如下面的代码所示

How to name the newly created sheet, "Summary" and placed as the first sheet?

通过使用 before 参数和 .Name 属性。

Set wsReport = ThisWorkbook.Sheets.Add(before:= ThisWorkbook.Sheets(1))
wsRTeport.Name = "Summary"

您将在下面修改后的代码的突出显示部分中找到更多详细信息。顺便说一句，我删除了 rLastCell 和从最后一个单元格进行的搜索，它在代码中没有意义。一旦您确认这些修改是您要查找的内容，也可以删除 rFirstCell。

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