Find a specific text and cut all the lines below it and paste to another sheet - excel

Question

I am trying to find the word "BREAK" and cut the lines below it until it reaches another word "BREAK" and transfer it to another Sheet.
I need to separate it to 5 sheets since I have 5 word of "BREAK" in the file.
Sub Fails()
Dim mFind As Range
Set mFind = Columns("A").Find("BREAK")
If mFind Is Nothing Then
MsgBox "There is no cell found with the text 'BREAK'" _
& " in column A of the active sheet."
Exit Sub
End If
firstaddress = mFind.Address
Do
If IsDate(mFind.Offset(1, 0)) = True Then
Range(mFind, Cells(mFind.Row + 2, "A")).EntireRow.Cut
Sheets("Sheet2").Select
Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Select
ActiveSheet.Paste
ElseIf WorksheetFunction.IsNumber(mFind.Offset(1, 0)) = True Then
Range(mFind, Cells(mFind.Row + 3, "A")).EntireRow.Cut
Sheets("Sheet2").Select
Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Select
ActiveSheet.Paste
End If
Sheets("Sheet1").Select
Set mFind = Columns("A").FindNext(mFind)
If mFind Is Nothing Then Exit Sub
Loop While mFind.Address <> firstaddress
End Sub
Nothing is happening with the code above. Any help would be greatly appreciated.
Thank you and have a good day everyone.

Answer 1

Give this code a try, your If statement was false
Sub Fails()
Dim mFind As Range
Dim Compteur As Integer
Dim IdSheet As Integer
Dim ErrorBool As Boolean
Set mFind = Columns("A").Find("Break")
Set mfind2 = Columns("A").Find("Break")
If mFind Is Nothing Then
MsgBox "There is no cell found with the text 'Break'" _
& " in column A of the active sheet."
Exit Sub
End If
firstaddress = mFind.Address
IdSheet = 1
Compteur = 0
Do
Set mfind2 = Columns("A").FindNext(mFind)
If mfind2 Is Nothing Then
Compteur = Sheet1.Range("A1048576").End(xlUp).Row
'Exit Sub
Else:
If mFind.Row < mfind2.Row Then
Compteur = mfind2.Row
End If
If mFind.Row > mfind2.Row Then
ErrorBool = True
End If
If ErrorBool = True Then
Range(mFind, Cells(mFind.Row + 1, "A")).EntireRow.Cut
End If
End If
Range("A" & mFind.Row + 1 & ":A" & Compteur - 1).EntireRow.Cut
If mFind Is Nothing Then
Else: IdSheet = IdSheet + 1
End If
Sheets("Sheet" & IdSheet & "").Select
Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Select
ActiveSheet.Paste
Sheets("Sheet1").Select
Range(mFind, Cells(mFind.Row, "A")).EntireRow.Delete
Set mFind = Columns("A").Find("Break")
Set mfind2 = Columns("A").Find("Break")
If mFind Is Nothing Then Exit Sub
Set mFind = Columns("A").FindNext(mFind)
Loop While mFind.Address <> firstaddress
End Sub
Note : You must create Sheet1, Sheet2, Sheet3, Sheet4 ,Sheet5 and so on before run macro.