Copy cells in a new sheet by separator VBA - vba

Question

I have this problem in Excel that I want to solve using Macros in VBA. I have a sheet that contains data in this format:
separator
1
2
6
3
8
342
532
separator
72
28
10
21
separator
38
23
234
What I want to do is to create a VBA macro that creates a new sheet for every series of data (a series starts from the "separator" and ends before the next one or at the end of the initial sheet) and copy respective data in the new sheets.
Example:
1
2
6
3
8
342
532
in sheet1
72
28
10
21
in sheet2 etc.
Thank you very much, I appreciate it!
This copies data from beginning to the first separator ("q"):
Sub macro1()
Dim x As Integer
x = 1
Sheets.Add.Name = "Sheet2"
'Get cells until first q
Do Until Sheets("Sheet1").Range("A" & x).Value = "q"
Sheets("Sheet2").Range("A" & x).Value = Sheets("Sheet1").Range("A" & x).Value
x = x + 1
Loop
End Sub

Answer 1

Try this... (UNTESTED)
Const sep As String = "q"
Sub Sample()
Dim ws As Worksheet, wsNew As Worksheet
Dim lRow As Long, i As Long, rw As Long
'~~> Set this to the relevant worksheet
Set ws = ThisWorkbook.Sheets("Sheet1")
'~~> Add a new temp sheet
Set wsNew = ThisWorkbook.Sheets.Add
'~~> Set row for the new output sheet
rw = 1
With ws
'~~> Get the last row
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
'~~> Loop through the cells from row 2
'~~> assuming that row 1 has a spearator
For i = 2 To lRow
If .Range("A" & i).Value = sep Then
Set wsNew = ThisWorkbook.Sheets.Add
rw = 1
Else
wsNew.Cells(rw, 1).Value = .Range("A" & i).Value
rw = rw + 1
End If
Next i
End With
End Sub

Answer 2

You could use this to avoid Looping every row. As long as you want to delete the original data as well.
SubSample()
Dim x As Integer
Dim FoundCell As Range
Dim NumberOfQs As Long
Dim SheetWithData As Worksheet
Dim CurrentData As Range
Set SheetWithData = Sheets("Sheet4")
NumberOfQs = WorksheetFunction.CountIf(SheetWithData.Range("A:A"), "q")
x = 1
Set FoundCell = SheetWithData.Range("A1", SheetWithData.Range("A" & Rows.Count)).Find("q", , , , , xlPrevious)
If Not FoundCell Is Nothing Then
Set LastCell = FoundCell.End(xlDown)
Set CurrentData = SheetWithData.Range(FoundCell, LastCell)
Sheets.Add.Name = "QSheetNumber" & x 'Get cells until first q
CurrentData.Cut Sheets("QSheetNumber" & x).Range("A1")
Sheets("QSheetNumber" & x).Rows(1).Delete
x = x + 1
Set FoundCell = SheetWithData.Range("A1", SheetWithData.Range("A" & Rows.Count)).Find("q", FoundCell, , , , xlPrevious)
If Not FoundCell Is Nothing Then
Set LastCell = FoundCell.End(xlDown)
Set CurrentData = SheetWithData.Range(FoundCell, LastCell)
Sheets.Add.Name = "QSheetNumber" & x 'Get cells until first q
CurrentData.Cut Sheets("QSheetNumber" & x).Range("A1")
Sheets("QSheetNumber" & x).Rows(1).Delete
x = x + 1
Else
Exit Sub
End If
Else
Exit Sub
End If
End Sub