Question

开发的代码

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

如何命名新创建的工作表，＆＃34;摘要＆＃34;并作为第一张纸放置？

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

感谢您的帮助和时间。

以下是代码：

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

如何在每个工作表中找到每个找到的行条目，以便在找到关键字时只显示一次？

开始循环Do ... Loop Until 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

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

1 个答案: