怎样将黄色高亮行之间的行提取到一个单独的工作表中？

jscsj

怎样将黄色高亮行之间的行提取到一个单独的工作表中？

附件表格中，有很多黄色高亮的行，还有其他高亮的行
现在我想把黄色高亮的行之间的数据行（包括黄色行本身）提取到一个单独的工作表中
比如从第1个黄色行到第2个黄色行之间的行，第3个黄色行到第4个黄色行之间的行，第5个黄色行到第6个黄色行之间的行，以此类推，提取放到一个单独的工作表中。

请各们高手帮我指点，谢谢！！！

A1233515

附件供参考

jscsj

A1233515 你好！你的代码能实现 但因为我看不懂代码，只知道复制粘贴。
但我换了一个Excel文件后，再直接复制粘贴就实现不了了，

请帮我说明一下，换文件后应该怎样做，非常感谢！！！

jscsj

这么快就回复我了，真是太感谢了。
但换一个文件后，直接复制粘贴宏代码，还是不行，等我明天再领会一下，再试！

再次感谢！

jscsj

不懂就是不懂，还是要到这里来问高手

换一个EXCEL文件后，直接复制粘贴 A1233515 写的   宏代码  不知道怎样才能实现，请高手指教

Sub fuzhi()
Dim arr, brr, rng As Range, i&, k&, m&, n&
Dim p&
i = Sheet1.UsedRange.Rows.Count
ReDim arr(1 To i / 2)
ReDim brr(1 To i / 2)
For Each rng In Sheet1.Range("a1:a" & i)
  If rng.Interior.Color = RGB(255, 255, 0) Then
    k = k + 1
    If Int(k / 2) = k / 2 Then
      m = m + 1
      brr(m) = rng.Row
    Else
      n = n + 1
      arr(n) = rng.Row
    End If
  End If
Next
Worksheets.Add after:=Sheets(1)
ActiveSheet.Name = "复制1121"
Sheet1.Range("1:1").Copy ActiveSheet.Range("a1")
For p = 1 To UBound(arr)
  If arr(p) <> "" And brr(p) <> "" Then
    Sheet1.Range(arr(p) & ":" & brr(p)).Copy ActiveSheet.Range("a" & Rows.Count).End(xlUp).Offset(1, 0)
  End If
Next
End Sub