从Excel中的提示中搜索关键字，然后使用摘要第2部分创建新选项卡

这个问题是由开发的代码的构建

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

• 如何将新创建的工作表命名为“摘要”，并作为第一张工作表放置

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

谢谢你的帮助和时间

代码如下：

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

Private子FindAndCreateReport（）
'声明我们将用于循环每个工作表的变量
将eWs设置为工作表
暗光范围
'声明变量以检查我们是否完成了在工作表中的循环
Dim rLastCell As范围
Dim rFirstCell As范围
'声明并准备变量以保存我们要查找的字符串
作为字符串的Dim strLookFor
strLookFor=InputBox（“要搜索的文本”）
如果Len（Trim（strLookFor））=0，则退出Sub
'声明并准备创建报告时使用的变量
Dim rCellwsReport As范围
以工作表形式提交报告
设置wsReport=thiswoolk.Sheets.Add
设置rCellwsReport=wsReport.Cells（1,1）
出现错误时，请继续下一步'
如何使每个工作表中找到的行条目在找到关键字时只显示一次

通过在循环的下一行开始下一次搜索
Do。。。循环直到rFound.Address=rFirstCell.Address

如何将找到的行列附加到已创建的工作表中，如下所示：

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

如何将新创建的工作表命名为“摘要”，并作为第一张工作表放置

通过使用
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

Private子FindAndCreateReport（）
'声明我们将用于循环每个工作表的变量
将eWs作为工作表、rFound作为范围、rFirstCell作为范围
'声明并准备变量以保存我们要查找的字符串
作为字符串的Dim strLookFor
strLookFor=InputBox（“要搜索的文本”）
如果Len（Trim（strLookFor））=0，则退出Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'在第一个位置创建报告表，然后将其命名为“摘要”
Dim wsReport作为工作表，rCellwsReport作为范围
设置wsReport=ThisWorkbook.Sheets.Add（之前：=ThisWorkbook.Sheets（1））
wsReport.name=“摘要”
设置rCellwsReport=wsReport.Cells（1,1）
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
“出错后继续下一步”@A.S.H.。谢谢！你帮了我很大的忙！不过还是一个问题。每张工作表可能有多个“文本搜索”条目。是否有办法继续搜索工作表，直到找到所有“搜索文本”，然后继续搜索下一个工作表？例如，第2页的$F$2、$F$5、$F$33行中可能有“失败”一词。此外，是否可以保留找到的行的格式（如单元格颜色等）？非常感谢你的帮助和时间！我用原始数据的外观图片更新了这个问题。再次感谢@乔，不客气。至于从每张表中找到多个匹配项，当然是可能的，但我认为您不希望从OP的句子中看到这一点：“当找到关键字时，如何只有一个条目？”那么您的意思是什么？谢谢您的回答。在原始代码中，同一个“found”关键字将有重复的条目。也就是说，如果在工作表行中找到关键字，则同一行将在摘要工作表中至少出现两次。我的语句“只有一个条目”意味着每个找到的行只显示一次。希望这能把事情弄清楚。我将对我的原始问题进行编辑，以澄清这一说法。此外，格式也可以转移到汇总表中。非常感谢您的时间和帮助！衷心感谢您的时间和帮助！这正是需要的！