Найдите определенный текст, обрежьте все строки под ним и вставьте на другой лист.

Question

Я пытаюсь найти слово «BREAK» и обрезать линии под ним, пока оно не достигнет другого слова «BREAK», и перенести его на другой лист.

Мне нужно разделить его на 5 листов, так как у меня в файле 5 слов "BREAK".

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

Ничего не происходит с кодом выше. Любая помощь будет принята с благодарностью.

Спасибо и всем хорошего дня.

Answer 1

Попробуйте этот код, ваше утверждение If было ложным

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

Примечание : Вы должны создать Лист1, Лист2, Лист3, Лист4, Лист5 и т. Д. До запуска макроса.