Как найти определенное слово и перенести его на другой лист вместе со строками под определенным словом

Question

Код должен обнаружить слово «EXECSDATE» в столбце B листа 1 и скопировать строку вместе со строками под ним в Sheet2, пока оно не достигнет другого слова «EXECSDATE».Поскольку у меня есть 5 «EXECSDATE» в Sheet1, должно быть разделено в общей сложности 5 листов.

Я уже попытался запустить свой код, но он показывает некоторую ошибку и не может сделать то, что должен.

Sub Fails()
    Dim mFind As Range
    Dim Compteur As Integer
    Dim IdSheet As Integer
    Dim ErrorBool As Boolean

debut:
    Set mFind = Columns("B").Find("EXECSDATE")
    Set mfind2 = Columns("B").Find("EXECSDATE")
    If mFind Is Nothing Then
        MsgBox "There is no cell found with the text 'EXECSDATE'" _
            & " in column A of the active sheet."
        Exit Sub
    End If

    firstaddress = mFind.Address
    IdSheet = 1
    Compteur = 0

    Do
        Set mfind2 = Columns("B").FindNext(mFind)
        If mfind2 Is Nothing Then
            Compteur = 0
        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, "B")).EntireRow.Cut
            End If
        End If

        Range("B" & mFind.Row + 1 & ":B" & Compteur - 1).EntireRow.Cut

        If mFind Is Nothing Then
        Else: IdSheet = IdSheet + 1
        End If

        Sheets("Sheet" & IdSheet & "").Select
        Range("B" & Rows.Count).End(xlUp).Offset(1, 0).Select
        ActiveSheet.Paste
line:
        Sheets("Sheet1").Select
        Range(mFind, Cells(mFind.Row, "B")).EntireRow.Delete
        Set mFind = Columns("B").Find("EXECSDATE")
        Set mfind2 = Columns("B").Find("EXECSDATE")
        If mFind Is Nothing Then Exit Sub
        Set mFind = Columns("B").FindNext(mFind)

    Loop While mFind.Address <> firstaddress
End Sub

Сообщение об ошибке:

Этот выбор недействителен.Убедитесь, что области копирования и вставки не перекрываются, если только они не имеют одинаковый размер и форму.

Вот первое слово EXECSDATE (которое должно идти к Листу 1):

Вот второе слово EXECSDATE (которое должно идти к Листу 2):

Answer 1

Этот ответ сработает, если вы избавитесь от всех двойных «EXECSDATE», как вы и сказали, и предположим, что B1 содержит «EXECSDATE»:

Sub Combine()
Dim x as Variant, rng as Range, CRng as Range, s as String
Dim LastRow as Long, i as Long
i = 2 : s = "EXECSDATE"

With ThisWorkbook.Worksheets("Sheet1")
    LastRow = .Range("B" & .Rows.count).End(xlUp).Row
    Do While i <= LastRow
        Set rng = .Range("B" & i & ":B" & LastRow)
        x = Application.Match(s, rng, 0)
        If IsError(x) Then
            Set CRng = .Rows(i-1 & ":" & LastRow)
            CRng.Copy Destination:= Worksheets.Add.Range("A1")
            Exit Do
        Else
            Set CRng = .Rows(i-1 & ":" & i+x-2)
            CRng.Copy Destination:= Worksheets.Add.Range("A1")
            i = i + x
        End If
    Loop
End With

End Sub