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

我有一个excel文件，其中有许多工作表（选项卡）。我想在excel中创建一个脚本，这样当您点击run时，会出现一个提示，询问“要搜索的文本”，然后在输入文本后，“失败”，例如，脚本然后搜索每个工作表。然后创建一个摘要表，其中包含关键字文本搜索中各个选项卡中的单元格行

---

谢谢你的帮助。

给你，把这个贴在普通模块上

    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

---

现在，这将不会创建报告，而是需要首先创建一个工作表，该工作表将接收所有文本。您需要根据需要更新行

Set wsReport=thiswoolk.Sheets（“接收者”）

您的代码中的哪一部分导致了问题？谢谢您的帮助-您实际上没有请求任何帮助。我甚至没有看到任何问题。也没有任何代码。也没有任何错误。阅读并提供一个示例将帮助我们帮助您。您好，衷心感谢您的代码。我运行了你的代码，但在创建的新选项卡中让单元格重复。也就是说，相同的单元格编号将在输出中显示两次。另外，如何在输出的下一列中添加行数据本身？我真诚地感谢你的时间和帮助！

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