在两个值VBA之间复制行并粘贴到新的表循环

我试图找出一些代码在这里，我已经看了几个网站现在，包括这里，它几乎可以工作，但它很可能是我的数据表是造成这个问题。 这： search两个值，并在循环之间复制所有内容 ： 我需要代码复制两行之间，并粘贴到另一个表与我们给予任何值？

可能会工作，但是第一个值无法find。 让我解释。

我有一个来自网站的导出报告，它将总计与一个名称（值1），然后单词总计为:(字2）。

我需要做的只是复制并粘贴符合值1的值，值2总是“合计为”。 这个循环的问题是每组数据之间都有空白，所以它find了第一个“总数”，但找不到我的第一个值，因为它在大约20个空白单元格之间。 （19组数据 – 每组之间空白行）。

我怎么能修复上面的代码，以便它继续下去的行，无论空白find第一个值，然后find第二个值。 复制该范围到一个新的工作表，并重新这个新的值1？

Sub MoveRows() Dim rownum As Integer Dim colnum As Integer Dim startrow As Integer Dim endrow As Integer rownum = 1 colnum = 1 With ActiveWorkbook.Worksheets("Sheet1") Do If .Cells(rownum, 1).Value = "LIFEC - Supp Life - Ch" Then startrow = rownum End If rownum = rownum + 1 Loop Until .Cells(rownum, 1).Value = "Totals for:" endrow = rownum ActiveWorkbook.Worksheets("Sheet1").Range(startrow & ":" & endrow).Copy End With ActiveWorkbook.Worksheets("Sheet2").Paste End Sub 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("Sheet1").Range("A65536").End(xlUp).Row With ActiveWorkbook.Worksheets("Sheet1").Range("A1:A" & lastrow) For rownum = 1 To lastrow Do If .Cells(rownum, 1).Value = "LIFEC - Supp Life - Ch" Then startrow = rownum End If rownum = rownum + 1 If (rownum > lastrow) Then Exit For Loop Until .Cells(rownum, 1).Value = "Totals for:" endrow = rownum rownum = rownum + 1 Worksheets("Sheet1").Range(startrow & ":" & endrow).Copy Sheets("Sheet2").Select Range("A1").Select ActiveSheet.Paste Next rownum End With End Sub 

我附上几乎可以工作的代码，但找不到我的第一个价值。

Answer 1

您可以使用Find方法，如下所示：

 Dim s As Range, e As Range With Sheet1 'or this can be any other sheet where you search Set r = .Range("A:A").Find("Whatever you want found") If Not r Is Nothing Then Set e = .Range("A:A").Find("The other end", r) If Not e Is Nothing Then .Range(r, e).EntireRow.Copy Sheet2.Range("A1") 'or to whatever sheet End If End If End With 

然后你可以在一个循环中取代你想要find的string。 HTH。