Question

我有一个包含许多工作表（标签）的Excel文件。我想在excel中创建一个脚本，这样当你点击运行时，会出现一个提示，要求＆＃34; Text搜索＆＃34;，然后在输入文本后，＆＃34;失败＆＃34;例如，脚本然后搜索每个工作表。然后创建一个摘要表，其中包含来自键文本搜索的各个选项卡中的单元格行。

感谢您的帮助。

Answer 1

在这里，将其粘贴到常规模块上，

    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

以及此代码。

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

现在，这不会创建报告，您需要首先创建一个将接收所有文本的工作表。您需要根据需要更新专线Set wsReport = ThisWorkbook.Sheets("receiver")。

在Excel中从提示中搜索关键字，然后创建包含摘要

1 个答案: