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

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"?