find and select the finding until the next find

Question

Basically, I'm writing a code that finds text in a Master sheet, I am looking for "Admin" after finding the admin I need to select from this cell unit next find and paste in separate sheets.

I tried different ways but now work, any suggestions?

Example

Sub FindNext_Example()
Dim FindValue As String
FindValue = "Bangalore"
Dim Rng As Range
Set Rng = Range("A2:A11")
Dim FindRng As Range
Set FindRng = Rng.Find(What:=FindValue)
Dim FirstCell As String
FirstCell = FindRng.Address

Do
Range(FristCell).Select
Selection.Copy
Worksheets.Add
ActiveSheet.Paste
Sheets("Sheet0").Select
Set FindRng = Rng.FindNext(FindRng)
Loop While FirstCell <> FindRng.Address

MsgBox "Search is over"

End Sub

Example

Example of finding and select the find row until next find

paste in new sheet

next find

until the end

Answer 1

Try this code:

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

Select the sheet with the data you want to chop and run it.

Answer 2

Create Criteria Worksheets

• Adjust the values in the constants section.

The Code

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