Vba 将超过阈值的值复制到新图纸

我希望创建一个宏，该宏将在一列中搜索超过设置阈值的值，然后将这些值以及行中的一些其他值复制到不同工作表中的表中

我使用for循环实现了这一点，但是我目前只使用了一个小数据集（~200行），它最多需要处理60000行左右的数据，根据我的经验，for循环在使用大量数据时往往效率低下

以下是我所拥有的：

Sub MondayTable()

Dim ShMonday As Worksheet
Dim ShSummary As Worksheet


Set ShMonday = ThisWorkbook.Sheets("Monday Data")
Set ShSummary = ThisWorkbook.Sheets("Summary")

Dim rCount As Integer
Dim AlertRow As Integer
Dim ActionRow As Integer

ActionRow = 17
AlertRow = 17

' Action Level

For rCount = 310 To 550

If ShMonday.Cells(rCount, 12) > 0.5 Then

    ShSummary.Cells(ActionRow, 5) = ShMonday.Cells(rCount, 12)   ' PPV
    ShSummary.Cells(ActionRow, 4) = ShMonday.Cells(rCount, 7)   ' Time

    ActionRow = ActionRow + 1

End If

' Alert Level

If ShMonday.Cells(rCount, 12) > 0.3 And ShMonday.Cells(rCount, 12) < 0.5 Then

     ShSummary.Cells(AlertRow, 3) = ShMonday.Cells(rCount, 12)   ' PPV
     ShSummary.Cells(AlertRow, 2) = ShMonday.Cells(rCount, 7)   ' Time

AlertRow = AlertRow + 1

End If


Next rCount


End Sub

Sub MondayTable（）
将星期一作为工作表
将摘要设置为工作表
Set ShMonday=thiswook.Sheets（“星期一数据”）
Set ShSummary=此工作簿.Sheets（“摘要”）
Dim rCount为整数
将行设置为整数
将行设置为整数
ActionRow=17
AlertRow=17
“行动层面
对于rCount=310至550
如果ShMonday.Cells（rCount，12）>0.5，则
ShSummary.Cells（ActionRow，5）=ShMonday.Cells（rCount，12）'PPV
ShSummary.Cells（ActionRow，4）=ShMonday.Cells（rCount，7）”时间
ActionRow=ActionRow+1
如果结束
"警戒级别",
如果ShMonday.Cells（rCount，12）>0.3，且ShMonday.Cells（rCount，12）<0.5，则
ShSummary.Cells（AlertRow，3）=ShMonday.Cells（rCount，12）'PPV
ShSummary.Cells（AlertRow，2）=ShMonday.Cells（rCount，7）”时间
AlertRow=AlertRow+1
如果结束
下一次计数
端接头

我想补充的另一件事是，我正在创建的表格总结了每天超过阈值的数字，目前我为每一天都有一个按钮。我如何执行相同的功能，在不同的工作表上搜索数据，其中输出仅使用一个按钮进入摘要工作表中的相邻列

另外，当我在这里时，如果可以在开始处添加一行来清除表的当前内容，那将是一个额外的奖励

谢谢

---

Chris

'要清除内容，请使用以下内容

ShSummary.Columns（“C:C”）.ClearContents ShSummary.Columns（“D:D”）.ClearContents

”“或者

ShSummary.Columns（“C:D”）.ClearContents

“为了提高效率，您可以保存ppv值，而不是多次引用它

暗淡ppv

如果ppv=”“，则“您还可以先检查它是否为空，然后跳到末尾 rcount=60000'或需要注意整数限制的任何高值 “虽然你快到了 其他的 ppv=cdbl（ShMonday.Cells（rCount，12））

如果结束

“最后，您可以调用第二个过程，这样就不需要第二个按钮

---

调用otherprocedurename

您可以通过首先对相关列上的数据块进行排序来减少for循环必须经历的迭代次数：

'declare ranges to leverage Excel's built-in sort capability
Dim DataBlock As Range, SortHeader As Range

'assuming the column header is one row up from the start of the loop and
'the 12th column is the last in the block of data
Set SortHeader = ShMonday.Cells(309, 12)
Set DataBlock = ShMonday.Range(ShMonday.Cells(309, 1), ShMonday.Cells(550, 12))

'sort the data block in descending order
DataBlock.Sort Key1:=SortHeader, Order1:=xlDescending, Header:=xlYes

然后，使用已排序的数据块，您可以在越过低阈值后退出for循环：

For rCount = 310 To 550

    ' Action level    
    If ShMonday.Cells(rCount, 12) > 0.5 Then
        ShSummary.Cells(ActionRow, 5) = ShMonday.Cells(rCount, 12)   ' PPV
        ShSummary.Cells(ActionRow, 4) = ShMonday.Cells(rCount, 7)   ' Time
        ActionRow = ActionRow + 1
    End If

    ' Alert Level
    If ShMonday.Cells(rCount, 12) > 0.3 And ShMonday.Cells(rCount, 12) < 0.5 Then
        ShSummary.Cells(AlertRow, 3) = ShMonday.Cells(rCount, 12)   ' PPV
        ShSummary.Cells(AlertRow, 2) = ShMonday.Cells(rCount, 7)   ' Time
        AlertRow = AlertRow + 1
    End If

    'Exit the loop
    If ShMonday.Cells(rCount, 12) <= 0.3 Then 
        Exit For
    End If
Next rCount

rCount=310到550的

“行动层面
如果ShMonday.Cells（rCount，12）>0.5，则
ShSummary.Cells（ActionRow，5）=ShMonday.Cells（rCount，12）'PPV
ShSummary.Cells（ActionRow，4）=ShMonday.Cells（rCount，7）”时间
ActionRow=ActionRow+1
如果结束
"警戒级别",
如果ShMonday.Cells（rCount，12）>0.3，且ShMonday.Cells（rCount，12）<0.5，则
ShSummary.Cells（AlertRow，3）=ShMonday.Cells（rCount，12）'PPV
ShSummary.Cells（AlertRow，2）=ShMonday.Cells（rCount，7）”时间
AlertRow=AlertRow+1
如果结束
'退出循环
如果说ShMonday.Cells（rCount，12）啊，首先对数据进行排序是我没有想到的。我要试一试。应该可以节省数百次迭代。嘿@holmes321，如果我的答案令人满意，我将感谢您将其标记为正确。谢谢
For rCount = 310 To 550

    ' Action level    
    If ShMonday.Cells(rCount, 12) > 0.5 Then
        ShSummary.Cells(ActionRow, 5) = ShMonday.Cells(rCount, 12)   ' PPV
        ShSummary.Cells(ActionRow, 4) = ShMonday.Cells(rCount, 7)   ' Time
        ActionRow = ActionRow + 1
    End If

    ' Alert Level
    If ShMonday.Cells(rCount, 12) > 0.3 And ShMonday.Cells(rCount, 12) < 0.5 Then
        ShSummary.Cells(AlertRow, 3) = ShMonday.Cells(rCount, 12)   ' PPV
        ShSummary.Cells(AlertRow, 2) = ShMonday.Cells(rCount, 7)   ' Time
        AlertRow = AlertRow + 1
    End If

    'Exit the loop
    If ShMonday.Cells(rCount, 12) <= 0.3 Then 
        Exit For
    End If
Next rCount