Search for two values and copy everything in between in a loop

Question

I have a worksheet which has many terms in Column A.I want to search for two terms for example term A and term B and copy all rows between the two terms and paste it into a new sheet.These two terms may repeat in the column. The problem which I am basically facing the following problem : whenever I run my code it also copies rows between term B and term A which is unnecessary. Following is the code i am using for two terms term A and term B. For example my column A is

Institute Event Job Computer Laptop Figures Event figures format computer

and many more terms I want to copy all the rows between term A: Event and term B: Laptop and paste it into a new sheet. What my code is doing is it is copying the rows between all combinations of Event and computer. Even the rows between computer and event are copied(in this case Figure and laptop).

Sub OpenHTMLpage_SearchIt()
    Dim Cell As Range, Keyword$, N%, SearchAgain As VbMsgBoxResult
    Dim ass As Variant
    Dim Cellev As Range, prakash$, P%, SearchAgaina As VbMsgBoxResult
    Dim asa As Variant


StartSearch:
    N = 1
    Keyword = "Event"

    If Keyword = Empty Then GoTo StartSearch
    For Each Cell In Range("A1:A500")
        If Cell Like "*" & Keyword & "*" Then

        ass = Cell.Address

        P = 1
        prakash = "Computer"
        If prakash = Empty Then GoTo StartSearch
            For Each Cellev In Range("A1:A500")
                If Cellev Like "*" & prakash & "*" Then
                    asa = Cellev.Address

                    Range(asa, ass).Select
                    Selection.Copy
                    Sheets.Add After:=Sheets(Sheets.Count)
                    Range("B13").Select
                    ActiveSheet.Paste

                    Worksheets("sheet1").Select
                    P = P + 1
                End If
            Next Cellev
            N = N + 1
        End If
    Next Cell

End Sub

Edit: code formatting.

Answer 1

The following is the code which is working for me.This copies everything in between Event and laptop and pastes it into a new sheet. Then again it searches for a second time and this time the search will start from the next row to the first search.I hope I am clear with this.

  Sub Star123()
   Dim rownum As Long
   Dim colnum As Long
   Dim startrow As Long
   Dim endrow As Long
   Dim lastrow As Long
   rownum = 1
   colnum = 1
   lastrow = Worksheets("Startsheet").Range("A65536").End(xlUp).Row
   With ActiveWorkbook.Worksheets("StartSheet").Range("a1:a" & lastrow)


   For rownum = 1 To lastrow
    Do
       If .Cells(rownum, 1).Value = "Event" Then
          startrow = rownum
       End If

       rownum = rownum + 1


   If (rownum > lastrow) Then Exit For

   Loop Until .Cells(rownum, 1).Value = "Laptop"
   endrow = rownum
   rownum = rownum + 1

   Worksheets("StartSheet").Range(startrow & ":" & endrow).Copy


   Sheets("Result").Select
   Range("A1").Select
   ActiveSheet.Paste


   Next rownum
   End With
   End Sub

Answer 2

Try this:

Sub DoEeeeeet(sheetName, termA, termB)

    Dim foundA As Range, _
        foundB As Range
    Dim newSht As Worksheet

    With Sheets(sheetName).Columns(1)
        Set foundA = .Find(termA)
        If Not foundA Is Nothing Then
            Set foundB = .Find(termB, after:=foundA, searchdirection:=xlPrevious)
        End If
    End With

    If foundA Is Nothing Or foundB Is Nothing Then
        MsgBox "Couldn't find " & IIf(foundA Is Nothing, termA, termB)
    Else
        Range(foundA, foundB).Copy
        Set newSht = Sheets.Add
        newSht.Range("B13").PasteSpecial
    End If

End Sub

You can call it as follows:

DoEeeeeet "Sheet1","Event","Laptop"

It'll find the first instance of "Event" and the last instance of "Laptop" on the sheet named "Sheet1" and copy all of that data to B13 and subsequent cells in a new sheet.

Is that what you want? Or do you want each of the subranges beginning with "Event" and ending with "Laptop"?