vba - 搜索两个值并在循环中复制其间的所有内容

Question

我有一个工作表，其中 A 列中有许多术语。例如，我想搜索两个术语术语 A 和术语 B，复制这两个术语之间的所有行并将其粘贴到新工作表中。这两个术语可能会在列中重复。我基本上面临以下问题:每当我运行代码时，它也会复制术语 B 和术语 A 之间的行，这是不必要的。以下是我用于两个术语术语 A 和术语 B 的代码。例如我的A列是

研究所 事件 工作 电脑 笔记本电脑 人物 事件 人物 格式 计算机

还有更多术语我想复制术语 A:事件和术语 B:笔记本电脑之间的所有行并将其粘贴到新工作表中。我的代码正在做的是复制事件和计算机的所有组合之间的行。甚至计算机和事件之间的行也会被复制(在本例中为图形和笔记本电脑)。

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

编辑:代码格式。

Answer 1

以下是对我有用的代码。这会复制事件和笔记本电脑之间的所有内容并将其粘贴到新工作表中。然后它再次搜索，这次搜索将从下一行开始到第一次搜索。我希望我清楚这一点。

  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