将超出阈值的值复制到新工作表

Question

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

我已经实现了它使用一个for循环，但我目前只使用一个小的数据集(~200行)，它需要与多达60000左右行工作，在我的经验中，循环往往变得低效时使用大量的数据!

我有:

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

我想添加的另一件事是，我正在创建的表汇总了每天阈值以上的数字，目前我为每个值都设置了一个按钮。如何使用一个按钮执行相同的函数，在不同的工作表中搜索数据，其中输出到汇总表中的相邻列中?

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

谢谢,克里斯

Answer 1

您可以通过首先对相关列上的数据块进行排序来减少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

Answer 2

要清除内容，使用如下命令

ShSummary.Columns .ClearContents("C: C")ShSummary.Columns (D: D) .ClearContents

或

ShSummary.Columns (C, D) .ClearContents

'为了提高效率，你可以保存你的ppv值，而不是多次引用它。

if ppv = " then "您也可以先检查它是否为空，然后跳到末尾Rcount = 60000 '或无论它需要多大，都要注意整数限制虽然你快到了其他的ppv = cdbl(ShMonday. sh)细胞(rCount 12))

 If ppv > 0.5 Then 'etc....

如果

结束

'在结束时，你可以调用第二个过程，这样就不需要第二个按钮了

调用otherprocedurename