find and select the finding until the next find - excel

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