search两个值并在循环中复制所有内容

我有一个工作表，其中有很多条款列AI想search例如术语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 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 

你可以这样调用它：

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

它将在名为“Sheet1”的工作表上find“Event”的第一个实例和“Laptop”的最后一个实例，并将所有数据都复制到B13和后续单元格中。

那是你要的吗？ 或者你想要每个以“事件”开始并以“笔记本电脑”结尾的子范围？

Answer 2

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

  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