检查单元格值，匹配时复制

Question

我有一个不断增长的列表。

如果某个单元格值大于 10，则应将整行复制到某个工作表中。 如果值为 10 或更小，则应检查下一行，直到到达包含数据的最后一行。

这是我当前的宏。它将行复制到与以前相同的位置。我需要在没有可用空间的情况下列出它们。

Sub Copy()
Dim s1 As Worksheet, s2 As Worksheet
Dim N As Long, i As Long, j As Long
Set s1 = Sheets("Hours")
Set s2 = Sheets("Check")
N = s1.Cells(Rows.Count, "R").End(xlUp).Row
j = 1
For i = 1 To N
    If s1.Cells(i, "R").Value > "10" Then
       s1.Cells(i, "R").EntireRow.Copy s2.Cells(j, 1)
        j = j + 1
    End If
Next i
End Sub

Answer 1

您可以在完成当前脚本后进行后期处理，删除空行（将范围“C50”更改为列/行的最大范围以检查空）：

  dim r As Range, rows As Long, i As Long
  Set r = Sheets("Check").Range("A1:C5000")
  rows = r.rows.Count
  For i = rows To 1 Step (-1)
    If WorksheetFunction.CountA(r.rows(i)) = 0 Then r.rows(i).Delete
  Next

Answer 2

我尽量不离开你的原始代码（尽管使用AutoFilter 方法很诱人）

我认为您的错误是由于您没有完全限定您正在寻找N（最后一行）的方式；您使用了N = s1.Cells(Rows.Count, "R").End(xlUp).Row，如果ActiveSheet 是另一张表，那么您将得到Rows.Count 的不同值。我刚刚添加了工作表参考N = s1.Cells(s1.Rows.Count, "R").End(xlUp).Row

我添加了另一个“安全”标准，如果您在“R”列中有文本，我已将您的 If 标准修改为 'If IsNumeric(s1.Range("R" & i)) And s1 .Range("R" & i).Value > 10 Then`

代码

Sub Copy()

Dim s1 As Worksheet, s2 As Worksheet
Dim N As Long, i As Long, j As Long

Set s1 = Sheets("Hours")
Set s2 = Sheets("Check")

N = s1.Cells(s1.Rows.Count, "R").End(xlUp).Row
j = 1
For i = 1 To N
    If IsNumeric(s1.Range("R" & i)) And s1.Range("R" & i).Value > 10 Then
        s1.Cells(i, "R").EntireRow.Copy s2.Cells(j, 1)
        j = j + 1
    End If
Next i

End Sub