How to find a specific word and transfer it to another sheet together with the lines below the specific word

Question

The code needs to detect the word "EXECSDATE" in Sheet1 Column B and copy the line together with the lines below it to Sheet2 until it reaches another word "EXECSDATE." Since I have 5 "EXECSDATE" in Sheet1 there should be a total of 5 Sheets separated.

I already have tried running my code but it shows some error and can't do what it must.

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

Error Message:

This selection isn't valid. Make sure the copy and paste areas don't overlap unless they are the same size and shape.

Here is the first EXECSDATE word (which is supposed to go to Sheet1):

Here is the second EXECSDATE word (which is supposed to go to Sheet2):

Here: " End If Sheets("Sheet" & IdSheet & "").Select Range("B" & Rows.Count).End(xlUp).Offset(1, 0).Select ActiveSheet.Paste" — , Jul 10 '19 at 09:08
Think the problem is you are trying to paste an entire row into a range starting in column B so you are falling off the edge of the spreadsheet. — SJR, Jul 10 '19 at 09:17
how should I code it @JSR? Please help me, I'm new to VBA :( — , Jul 10 '19 at 09:30
You need to either not cut the whole row or paste starting in column A. — SJR, Jul 10 '19 at 09:34
And read this https://stackoverflow.com/questions/10714251/how-to-avoid-using-select-in-excel-vba — SJR, Jul 10 '19 at 09:34
its from a raw file provided by my proctor, it's my first time using VBA. I'm still not great using it :( — , Jul 10 '19 at 09:56
I have a plan on how am I going to remove them, the only thing that's stopping me is this part. I am really in need to separate that execsdate in 5 sheets together with the lines below them :( — , Jul 10 '19 at 09:57

score 0 · Accepted Answer · answered Jul 10 '19 at 12:39

This answer works if you get rid of all the double "EXECSDATE" like you said you would, and assumes B1 contains "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

It worked! thank you very much! I'll just delete the exceeding sheets. God bless you more!! — , Jul 11 '19 at 03:03
@Zha, you are welcome. God bless you too. You can also upvote as well. — AAA, Jul 11 '19 at 05:27

How to find a specific word and transfer it to another sheet together with the lines below the specific word

1 Answers1