excel 通过收集加快数据处理速度

a8jjtwal 于 2023-05-01 发布在其他

关注(0)|答案(3)|浏览(108)

我在Excel VBA代码中过滤和向集合添加数据时遇到问题。
我有两本书：SourceWB和SourceTR。我从两者收集数据，并将它们列在SourceTR中。目标是比较两个数据集并找到不匹配。代码在SourceTR处于活动状态时运行。
我省略了代码的其余部分，这里只是有问题的部分：

Debug.Print "3 -- " & Now
For Each i In Workbooks("SourceTR").Worksheets("Source1").Range("A4:A10000")
    If i.Value <> "" Then
        If month(i.Value) = selected_month Then
            item_1 = Worksheets("Source1").Range("E" & i.row).Value
            item_2 = Worksheets("Source1").Range("F" & i.row).Value
            item_3 = Worksheets("Source1").Range("K" & i.row).Value
            entry = item_1 & "_" & item_2 & "_" & item_3
            If IsInCollection(init_tr_entries, entry) = False Then
                init_tr_entries.Add (entry)
            End If
        End If
    End If
Next i

Debug.Print "4 -- " & Now

Dim coll_item
For Each coll_item In init_tr_entries
    Workbooks("SourceTR").Worksheets("target").Range("A" & starting_row_1).Value = Split(coll_item, "_")(0)
    Workbooks("SourceTR").Worksheets("target").Range("B" & starting_row_1).Value = Split(coll_item, "_")(1)
    Workbooks("SourceTR").Worksheets("target").Range("C" & starting_row_1).Value = Split(coll_item, "_")(2)
    starting_row_1 = starting_row_1 + 1
Next coll_item

Debug.Print "5 -- " & Now

Dim a As Range
Dim user As String
user = Worksheets("vir").Range("G2").Value

Dim init_as_entries As New Collection

For Each a In Workbooks("SourceWB"))).Worksheets("Source2")).Range("BU4:BU10000")
    If a.Value <> "" Then
        If a.Value = "" & selected_month & "" Then
            If Workbooks("SourceWB"))).Worksheets("Source2")).Range("F" & a.row).Value = user Then
                item_1 = Workbooks("SourceWB"))).Worksheets("Source2")).Range("A" & a.row).Value
                item_2 = Workbooks("SourceWB"))).Worksheets("Source2")).Range("B" & a.row).Value
                item_3 = Workbooks("SourceWB"))).Worksheets("Source2")).Range("E" & a.row).Value
                entry = item_1 & "_" & item_2 & "_" & item_3
                init_as_entries.Add (entry)
            End If
        End If
    End If
Next a

For Each coll_item In init_as_entries
    Workbooks("SourceTR").Worksheets("target").Range("F" & starting_row_2).Value = Split(coll_item, "_")(0)
    Workbooks("SourceTR").Worksheets("target").Range("G" & starting_row_2).Value = Split(coll_item, "_")(1)
    Workbooks("SourceTR").Worksheets("target").Range("H" & starting_row_2).Value = Split(coll_item, "_")(2)
    starting_row_2 = starting_row_2 + 1
Next coll_item

Debug.Print "6 -- " & Now

点3和点5之间的代码大约需要1秒，点5和点6之间的代码大约需要10秒。然而，除了一些过滤，我在代码中看不到任何区别。
数据集很小，SourceWB中有2500个非空白行，SourceTR中只有60个。
我做错了什么？
---编辑--我做了一些额外的测量，这部分：

For Each a In Workbooks("SourceWB"))).Worksheets("Source2")).Range("BU4:BU10000")
    If a.Value <> "" Then
        If a.Value = "" & selected_month & "" Then
            If Workbooks("SourceWB"))).Worksheets("Source2")).Range("F" & a.row).Value = user Then
                item_1 = Workbooks("SourceWB"))).Worksheets("Source2")).Range("A" & a.row).Value
                item_2 = Workbooks("SourceWB"))).Worksheets("Source2")).Range("B" & a.row).Value
                item_3 = Workbooks("SourceWB"))).Worksheets("Source2")).Range("E" & a.row).Value
                entry = item_1 & "_" & item_2 & "_" & item_3
                init_as_entries.Add (entry)
            End If
        End If
    End If
Next a

使用此速度增强只需7秒：

Application.ScreenUpdating = False
Application.Calculation = xlManual
Application.EnableEvents = False
Application.DisplayStatusBar = False
ActiveSheet.DisplayPageBreaks = False

excel

来源：https://stackoverflow.com/questions/76100963/speed-up-data-processing-with-collection

3条答案

按热度按时间

lymnna711#

要清理代码（这基本上不是速度问题），请使用Workbook和Worksheet变量：

Dim sourceWB As Workbook, sourceWs1 As Worksheet, sourceWS2 As Worksheet
Set sourceWB = Workbooks("SourceTR")
Set sourceWS1 = sourceWB.Worksheets("Source1")
Set sourceWS2 = sourceWB.Worksheets("Source2")

并且对于目标工作簿/工作表也类似。
现在是加速：VBA正在减慢的是Excel和VBA之间的接口。因此，你能做的最好的事情就是将 * 所有 * 相关的数据读入一个数组，然后循环遍历。此外，您应该检查最后一行数据是什么。阅读Find last used cell in Excel VBA以获得详细讨论，我将使用最常见的方法作为示例，检查是否适合您。下面的代码模拟了步骤3的逻辑：

Dim lastRow As Long
lastRow = sourceWs1.Cells(sourceWs1.Rows.Count, "A").End(xlUp).Row
Dim sourceData As Variant
sourceData = sourceWs1.Range("A4:K" & lastRow)

现在，您有了一个二维数组，其中包含第一个源工作表的数据副本。即使这是一个相当大的数组，阅读也不会比只读取单个数据单元慢多少。
您可以循环访问内存中的数据（这是即时发生的，您将无法测量执行时间）

Dim row As Long
For row = 1 To UBound(sourceData, 1)
    If sourceData(row, 1) <> "" Then
        If Month(sourceData(row, 1)) = selected_month Then
            Dim item_1, item_2, item_3, entry
            item_1 = sourceData(row, 5)   ' Col E
            item_2 = sourceData(row, 6)   ' Col F
            item_3 = sourceData(row, 11)  ' Col K
            entry = item_1 & "_" & item_2 & "_" & item_3

            If Not IsInCollection(init_tr_entries, entry) Then
                init_tr_entries.Add (entry)
           End If
        End If
    End If
Next row

写入数据也是如此：用要写入的数据准备一个数组

ReDim targetData(1 To init_tr_entries.Count, 1 To 3)
Dim coll_Items() As String
For row = 1 To init_tr_entries.Count
    coll_Items = Split(init_tr_entries(row), "_")
    targetData(row, 1) = coll_Items(0)  ' You could also use a loop for that
    targetData(row, 2) = coll_Items(1)
    targetData(row, 3) = coll_Items(2)
Next

现在您有了一个可以一次性写入的二维数据数组。我使用了一个中间范围变量，但这只是为了更好的可读性：

Dim targetRange As Range
Set targetRange = TargetWS.Range("A" & starting_row_1)
targetRange.Resize(UBound(targetData, 1), UBound(targetData, 2)).Value = targetData

赞(0）回复(0）举报 2023-05-01

ubof19bj2#

我终于找到了根本原因。我是通过使用如上所述的新工作簿到达那里的。但是，它不是格式和公式，而是工作簿名称。我在代码中通过工作簿的名称引用了它，而以前我使用查找函数来获取源工作簿的名称。
我试图解决的excel解决方案是一个更大的工作簿，模块和函数集的一部分，它们有几种语言（宏和工作簿）。因此，工作簿名称会更改。因此，我调用Workbooks(replaceYearInStr(getTranslation("some_wb_codename")))以得到Workbooks("SourceWB")。根据后端语言集的不同，可能会得到斯洛文尼亚语的Workbooks("IzvorWB")。
getTranslation函数使用lookup从语言工作表中获取名称，所以看起来这个函数会减慢它的速度。我仍然不想硬编码的名字，但至少我知道问题是什么。

赞(0）回复(0）举报 2023-05-01

jchrr9hc3#

你试过使用脚本吗？字典对象而不是集合？我有传闻证据表明，它们明显（也许不是数量级，但明显）比VBA中的集合快。使用CreateObject（“Scripting.Dictionary”）创建对象，而不必设置对Microsoft脚本运行时的引用，并将其分配给通用对象。

赞(0）回复(0）举报 2023-05-01