Excel中具有大型数据集的VBA子例程的速度问题

含咖啡因的迈克

我正在创建一个相当广泛的Excel宏,以帮助捕获文件上的常见错误,然后再将其导入到我们公司的系统中。经过大约一个月的开发,我已经将大部分功能编码到多个Sub(为了便于维护)中,我从主Sub中调用了该功能Alfred()

Sub Alfred() 'the butler 

    Application.ScreenUpdating = False
     Call fileCheck       '  0.57 seconds for 15000 rows
     Call symbolCheck     ' 31.57 seconds for 15000 rows
     Call trimTheHedges   ' 16.21 seconds for 15000 rows
     Call ctdCheck        '  0.28 seconds for 15000 rows
     Call lengthCheck     '  2.21 seconds for 15000 rows
     Call dupKeywordCheck '  0.54 seconds for 15000 rows
     Call colorCheck      '  2.56 seconds for 15000 rows
     Call PRTCheck        '  0.65 seconds for 15000 rows
     Call lminCheck       '139.26 seconds for 15000 rows <- See if we can decrease this and make one for RUSH too
     Call colOpNaCheck    '  0.80 seconds for 15000 rows
     Call colAddCLCheck   '  0.77 seconds for 15000 rows
     Call prodNumCheck    '  1.15 seconds for 15000 rows
     Call bpCheck         '  4.85 seconds for 15000 rows
     Call ucCheck         ' 10.75 seconds for 15000 rows
''''''''''''''''''''''''''''''''''''''''''''''
'''''Total 3.4992 minutes''209.95 seconds'''''
''''''''''''''''''''''''''''''''''''''''''''''
    Application.ScreenUpdating = True
End Sub

在对每个Sub进行计时之后,我意识到我的一个Subs需要很长时间才能完成(Sub lminCheck)。我希望有人可能对如何更好地完成在此特定Sub上执行的任务有所了解。如果可以使用可以加快此任务速度的任何方法,请提供示例(尽可能具体地提供)。我已经关闭ScreenUpdating并且不确定将“计算”转换为xlCalculationManual会很有用(也许我错了吗?),但是我确实在寻找一种方法来重组我的代码(也许使用数组,更好的编码实践等)。 ),这将改善我的Sub的处理时间。

'Checks for LMIN:Y Upcharge Criteria and checks off
'LMIN column of products where LMIN:Y exists
'Run this sub after sub that checks for empty criteria 1/invalid upcharges
'Columns CT & CU are Upcharge Criteria 1 & 2 and Column CP is LMIN
Private Sub lminCheck()

Dim endRange As Integer
Dim usedRange As Range
Dim row As Integer
Dim totalCount As Integer
Dim xid As String
Dim mainProdLine As String

endRange = ActiveSheet.Cells(Rows.count, "CS").End(xlUp).row
Set usedRange = ActiveSheet.Range("CT2:CU" & endRange)

'Count how many times LMIN:Y Upcharge criteria appears in Upcharge 1 & 2 columns
totalCount = WorksheetFunction.CountIf(usedRange, "*LMIN:Y*")

If totalCount <> 0 Then
    Dim lminCount As Integer
    For lminCount = 1 To totalCount
        'This gives us the row of this occurance
        row = Find_nth(usedRange, "LMIN:Y", lminCount)
        'Using row we can look at Column A of the same row to get the XID of the product
        xid = ActiveSheet.Range("A" & row).Value
        'Once we have the xid we can find the main/first line of the product
        Dim tempRange As Range
        Set tempRange = ActiveSheet.Range("A2:A" & endRange)
        mainProdLine = Find_nth(tempRange, xid, 1)
        'Using the main/first line of the product we can now check if the LMIN column is checked
        If ActiveSheet.Range("CP" & mainProdLine).Value <> "Y" Then
            'If column is not checked then check it
            ActiveSheet.Range("CP" & mainProdLine).Value = "Y"
        End If
    Next lminCount
Else
    'Exit entire sub since there are no instances of LMIN:Y to check
    Exit Sub
End If

End Sub

'This is the modified version of the Find_nth Function that is also able to find values if they are in the beginning of a string
Function Find_nth(rng As Range, strText As String, occurence As Integer)
Dim c As Range
Dim counter As Integer
For Each c In rng
    If c.Value = strText Then counter = counter + 1
    If InStr(1, c, strText) = 1 And c.Value <> strText Then counter = counter + 1
    If InStr(1, c, strText) > 1 Then counter = counter + 1
    If counter = occurence Then
        Find_nth = c.row
        '.Address(False,False) eliminates absolute reference ($x$y)
        Exit Function
    End If
Next c
End Function
用户4039065

您有很多重复的循环。为什么在工作表的“匹配”功能如此出色的情况下循环遍历所有单元格,直到找到匹配项

Private Sub lminCheck()
    Dim c As Long, vCOLs As Variant
    Dim rLMINY As Range, vXID As Variant, dXIDs As Object

    Debug.Print Timer
    'application.screenupdating = false '<~~ uncomment this once you are no longer debugging
    Set dXIDs = CreateObject("Scripting.Dictionary")
    dXIDs.comparemode = vbTextCompare

    vCOLs = Array(98, 99)  '<~~ columns CT & CU

    With Worksheets("Upcharge") '<~~ surely you know what worksheet you are supposed to be on
        If .AutoFilterMode Then .AutoFilterMode = False
        For c = LBound(vCOLs) To UBound(vCOLs)
            With Intersect(.UsedRange, .Columns(vCOLs(c)))
                .AutoFilter field:=1, Criteria1:="*LMIN:Y*"
                With .Resize(.Rows.Count - 1, .Columns.Count).Offset(1, 0)
                    If CBool(Application.Subtotal(103, .Cells)) Then
                        For Each rLMINY In .SpecialCells(xlCellTypeVisible)
                            dXIDs.Item(rLMINY.Offset(0, -(vCOLs(c) - 1)).Value2) = rLMINY.Value2
                        Next rLMINY
                    End If
                End With
                .AutoFilter
            End With
        Next c

        For Each vXID In dXIDs.keys
            .Cells(Application.Match(vXID, .Columns(1), 0), "CP") = "Y"
        Next vXID
        If .AutoFilterMode Then .AutoFilterMode = False
    End With

    dXIDs.RemoveAll: Set dXIDs = Nothing
    Application.ScreenUpdating = True
    Debug.Print Timer

End Sub

屏幕更新打开时,具有10%匹配项的15,000行样本数据耗时0.4秒,而屏幕更新关闭了0.2秒。

本文收集自互联网,转载请注明来源。

如有侵权,请联系 [email protected] 删除。

编辑于
0

我来说两句

0 条评论
登录 后参与评论

相关文章

具有大型数据集的 Mat Multi Select 中的性能问题

具有大型数据集的Laravel API加载速度非常慢

Excel如何将具有相同ID号的所有行合并到一个大型数据集的一列中?

Excel VBA在数组中存储函数或子例程

大型数据集的性能问题

有关过滤大型数据集的问题

具有大型数据集和多个维度的DC js

具有多个条件的反合并大型数据集

具有大型数据集的半径内的点数 - R

使用参数调用Excel VBA子例程

VBA EXCEL:如何在另一个子例程中调用一个子例程?

带有大型数据集示例的Blazorise Datagrid中的聚合

大型数据集的JQuery Datatables makeEditable()问题

大型数据集和 Cuda 内存问题

调用带有对象作为参数的子例程时的运行时错误Excel VBA

在具有大型数据集的Firebase数据库上查询非常慢

R:具有2个大型数据集的模式匹配财务时间序列数据:

在R中具有多个模拟条件的子帧数据集

如何查看VBA Excel 2016中已编译子例程的大小?

如何在excel vba中获取子例程以返回某些内容?

有效地合并具有多个匹配键的大型对象数据集

如何有效地训练具有大型图像数据集的 CNN 模型

有效检查大型数据集的子字符串

具有大型数据集的不完整 matplotlib 条形图

Cassandra:具有时间戳和大型数据集的表设计

将具有多个时区的大型数据集的本地日期时间转换为UTC

使用公式对具有设置结构的大型数据集进行转置

在VBA中具有多个条件的Excel表中查找数据

具有子字符串的Excel VBA自动筛选