问查找并选择查找结果，直到下一次查找

EN

Option Explicit

Sub addCriteriaWorksheets()
    
    Const wsName As String = "Sheet1"
    Const sCellAddress As String = "A1"
    Const Criteria As String = "Admin*"
    Const CriteriaColumn As Long = 3
    Const dCellAddress As String = "A1"
    
    Dim wb As Workbook: Set wb = ThisWorkbook
    
    Application.ScreenUpdating = False
    With wb.Worksheets(wsName).Range(sCellAddress).CurrentRegion
        .Worksheet.AutoFilterMode = False
        .AutoFilter CriteriaColumn, Criteria
        Dim rg As Range
        On Error GoTo SpecialCellsError
        Set rg = .Columns(CriteriaColumn).Resize(.Rows.Count - 1).Offset(1) _
            .SpecialCells(xlCellTypeVisible)
        On Error GoTo 0
        Dim nCount As Long: nCount = rg.Cells.Count
        Dim Coord As Variant: ReDim Coord(1 To nCount, 1 To 3)
        Dim arg As Range
        Dim cel As Range
        Dim n As Long
        For Each arg In rg.Areas
            For Each cel In arg.Cells
                n = n + 1
                Coord(n, 1) = cel.Row
                If n > 1 Then
                    Coord(n - 1, 2) = Coord(n, 1) - 1
                    Coord(n - 1, 3) = Coord(n - 1, 2) - Coord(n - 1, 1) + 2
                End If
            Next cel
        Next arg
        n = n + 1
        Coord(n - 1, 2) = .Rows.Count
        Coord(n - 1, 3) = Coord(n - 1, 2) - Coord(n - 1, 1) + 2
        .Worksheet.AutoFilterMode = False
        Dim cCount As Long: cCount = .Columns.Count
        Dim Data As Variant: Data = .Value
        Dim Result As Variant
        Dim i As Long, j As Long, k As Long
        For n = 1 To nCount
            ReDim Result(1 To Coord(n, 3), 1 To cCount)
            For j = 1 To cCount
                Result(1, j) = Data(1, j)
            Next j
            k = 1
            For i = Coord(n, 1) To Coord(n, 2)
                k = k + 1
                For j = 1 To cCount
                    Result(k, j) = Data(i, j)
                Next j
            Next i
            With wb.Worksheets.Add(After:=wb.Sheets(wb.Sheets.Count))
                .Range(dCellAddress).Resize(k, cCount).Value = Result
            End With
        Next n
        .Worksheet.Select
    End With
    
ProcExit:
    Application.ScreenUpdating = True
    Exit Sub
SpecialCellsError:
    Resume ProcExit
End Sub

Sub SubChopList()
    
    'Declarations.
    Dim DblColumnOffset As Double
    Dim RngSource As Range
    Dim RngSearch As Range
    Dim RngTop As Range
    Dim RngBottom As Range
    Dim StrSearch As String
    Dim StrDestinationAddress As String
    Dim WksSource As Worksheet
    
    'Settings.
    Set WksSource = ActiveSheet
    Set RngSource = WksSource.Range("A1")
    Set RngSource = Range(RngSource, RngSource.End(xlDown).End(xlToRight))
    
    'Setting DblColumnOffset equal to the offset from the first column of RngSource and the column to be searched.
    DblColumnOffset = 2
    
    'Setting the column to be searched.
    Set RngSearch = RngSource.Columns(1).Offset(0, DblColumnOffset)
    
    'Setting the value to be searched.
    StrSearch = "Admin"
    
    'Setting the address of the cell where the data will be pasted in the new sheets.
    StrDestinationAddress = "A1"
    
    'Setting RngTop as the first cell that contains StrSearch after the first cell of RngSearch.
    Set RngTop = RngSearch.Find(What:=StrSearch, _
                                After:=RngSearch.Cells(1, 1), _
                                LookIn:=xlValues, _
                                LookAt:=xlPart, _
                                SearchOrder:=xlByRows, _
                                SearchDirection:=xlNext, _
                                MatchCase:=False, _
                                SearchFormat:=False _
                               )
    
    'Setting RngBottom as the cell in the row upon the first cell that contains StrSearch after RngTop.
    Set RngBottom = RngSearch.Find(What:=StrSearch, _
                                   After:=RngTop, _
                                   LookIn:=xlValues, _
                                   LookAt:=xlPart, _
                                   SearchOrder:=xlByRows, _
                                   SearchDirection:=xlNext, _
                                   MatchCase:=False, _
                                   SearchFormat:=False _
                                  ).Offset(-1, 0)
    
    'Repeating until the last block is reached.
    Do
        'Creating a new sheet.
        Worksheets.Add
        
        'Copy-pasting the block delimited by RngTop and RngBottom in the new sheet at the address specified in StrDestinationAddress.
        WksSource.Range(RngTop, RngBottom).Offset(0, -DblColumnOffset).Resize(, RngSource.Columns.Count).Copy Range(StrDestinationAddress)
        
        'Setting RngTop as the first cell that contains StrSearch after RngBottom.
        Set RngTop = RngSearch.Find(What:=StrSearch, _
                                    After:=RngBottom, _
                                    LookIn:=xlFormulas, _
                                    LookAt:=xlPart, _
                                    SearchOrder:=xlByRows, _
                                    SearchDirection:=xlNext, _
                                    MatchCase:=False, _
                                    SearchFormat:=False _
                                   )
        
        'Setting RngBottom as the cell in the row upon the first cell that contains StrSearch after RngTop.
        Set RngBottom = RngSearch.Find(What:=StrSearch, _
                                       After:=RngTop, _
                                       LookIn:=xlValues, _
                                       LookAt:=xlPart, _
                                       SearchOrder:=xlByRows, _
                                       SearchDirection:=xlNext, _
                                       MatchCase:=False, _
                                       SearchFormat:=False _
                                      ).Offset(-1, 0)
        
    Loop Until RngTop.Row > RngBottom.Row
    
    'Reporting the last block as did for all the previous blocks in the Do Loop cycle.
    Set RngBottom = RngSearch.Cells(RngSearch.Rows.Count, 1)
    Worksheets.Add
    WksSource.Range(RngTop, RngBottom).Offset(0, -DblColumnOffset).Resize(, RngSource.Columns.Count).Copy Range(StrDestinationAddress)
    
End Sub