用新数据维护一个“图书馆”

Question

所以我正在尝试维护我在 excel 中拥有的库。我的图书馆与下表有点相同。这将在 45000 行上存储数年的数据。但是每个月我都会提取我想包含在数据中的新小时数。虽然可以及时更改数据，所以我总是提取 T、t-1、t-2 和 t-3。所以首先我想获取上个月的数据并将其从我的库中减去，加载新数据，然后添加新的时间。但是随着新数据的出现，总会有新的组合，我想将其添加到库的底部。我试图解决这个问题，并找到了解决方案，但由于我有一个很大的库而且每个月还要提取 85k 行，所以它花了很长时间。组合的原因是几个人可以在一个项目上列出时间，但我不关心谁做的，只是这些东西的组合。这也是为什么我的库中的行数较少的原因。有谁能够帮助我？我提供了我制作的代码，它在做正确的事情，但是速度变慢了。

Combination	Hours	ProjID	Planning	Approval	Month	Year	Hour type	Charge status
Proj1Planned42022Fixed	12	Proj1	Planned		4	2022	Fixed

Sub UpdateHours()
Dim data1 As Variant, data2 As Variant
Dim StartTime As Double
Dim MinutesElapsed As String

Application.ScreenUpdating = False

StartTime = timer

lastRow = Worksheets("TimeReg_Billable").Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).row
lastRowTRB = Worksheets("TimeRegistrations_Billable").Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).row

data1 = Worksheets("TimeReg_Billable").Range("A2:I" & lastRow).Value
data2 = Worksheets("TimeRegistrations_Billable").Range("A2:W" & lastRowTRB).Value

For i = 1 To lastRow
If i > UBound(data1, 1) Then Exit For
    For k = 1 To lastRowTRB
        If k > UBound(data2, 1) Then Exit For
        If data1(i, 1) = data2(k, 23) Then
            data1(i, 2) = data1(i, 2) - data2(k, 15)

        End If
    Next k
Next i

Worksheets("TimeReg_Billable").Range("A2:I" & lastRow).Value = data1


'Load data
'Workbooks.Open "C:\Users\jabha\Desktop\Projekt ark\INSERTNAMEHERE.xls"

'Workbooks("INSERTNAMEHERE.xls").Worksheets("EGTimeSearchControllingResults").Range("A:AA").Copy _
    Workbooks("Projekt.xlsm").Worksheets("TimeRegistrations_Billable").Range("A1")

'Workbooks("INSERTNAMEHERE.xls").Close SaveChages = False


'Insert the new numbers

lastRow = Worksheets("TimeReg_Billable").Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).row
lastRowTRB = Worksheets("TimeRegistrations_Billable").Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).row

myarray = Worksheets("TimeReg_Billable").Range("A2:A" & lastRow)

data1 = Worksheets("TimeReg_Billable").Range("A2:I" & lastRowTRB).Value
data2 = Worksheets("TimeRegistrations_Billable").Range("A2:W" & lastRowTRB).Value

i = 1
Do While i <= lastRow
If i > UBound(data1, 1) Then Exit Do
    k = 1
    Do While k <= lastRowTRB
        If k > UBound(data2, 1) Then Exit Do
        If data1(i, 1) = data2(k, 23) Then
            data1(i, 2) = data1(i, 2) + data2(k, 15)
        End If
        If Not data1(i, 1) = data2(k, 23) Then
            Teststring = Application.Match(data2(k, 23), myarray, 0)
            If IsError(Teststring) Then
                data1(lastRow, 1) = data2(k, 23)
                data1(lastRow, 3) = data2(k, 11)
                data1(lastRow, 4) = data2(k, 16)
                data1(lastRow, 5) = data2(k, 17)
                data1(lastRow, 6) = data2(k, 20)
                data1(lastRow, 7) = data2(k, 21)
                data1(lastRow, 8) = data2(k, 22)
                data1(lastRow, 9) = data2(k, 7)
                lastRow = lastRow + 1
                myarray = Application.Index(data1, 0, 1)
            End If
        End If
    k = k + 1
    Loop
    If data1(i, 9) = "#N/A" Then
        data1(i, 9) = ""
    End If
i = i + 1
Loop

Worksheets("TimeReg_Billable").Range("A2:I" & lastRowTRB).Value = data1

MinutesElapsed = Format((timer - StartTime) / 86400, "hh:mm:ss")
MsgBox "This code ran succesfully in " & MinutesElapsed & " minutes", vbInformation

End Sub

Answer 1

您的代码仅关闭 ScreenUpdating 但是，由于下面的行

Worksheets("TimeReg_Billable").Range("A2:I" & lastRow).Value = data1

在第一组嵌套循环之后更新工作表可能会触发 Excel 的计算引擎运行，因此在开始时也包括该行是明智的

Application.Calculation = xlCalculationManual 

虽然我没有任何证据，但理论上 UsedRange.Find 应该比 Cells.Find 更有效率，因为 UsedRange 必然是工作表中更小的区域。

使用.Value2 也比使用.Value 更有效率。

下面的代码

For i = 1 To lastRow
If i > UBound(data1, 1) Then Exit For
    For k = 1 To lastRowTRB
        If k > UBound(data2, 1) Then Exit For
        If data1(i, 1) = data2(k, 23) Then
            data1(i, 2) = data1(i, 2) - data2(k, 15)

        End If
    Next k
Next i

可以通过声明 2 个附加变量来改进

Dim outerLimit as Long, innerLimit as Long
outerLimit = Application.Min(lastRow, UBound(data1,1))
innerLimit = Application.Min(lastRowTRB, UBound(data2,1))
For i = 1 To outerLimit
    For k = 1 To innerLimit
        If data1(i, 1) = data2(k, 23) Then
            data1(i, 2) = data1(i, 2) - data2(k, 15)
        End If
    Next k
Next i

这从内部循环体中消除了 1 个测试和1 测试来自外环体。

（因为您在第二组嵌套循环中有类似的测试，您也可以在那里复制此优化）

在您的第二组嵌套循环中，您可以替换下面的代码

If data1(i, 1) = data2(k, 23) Then
    data1(i, 2) = data1(i, 2) + data2(k, 15)
End If
If Not data1(i, 1) = data2(k, 23) Then

与下面的

If data1(i, 1) = data2(k, 23) Then
    data1(i, 2) = data1(i, 2) + data2(k, 15)
Else
    

（显然也删除了后面的 End If 行之一）

由于 data1(i, 1) = data2(k, 23) 测试是布尔值，因此只需要对其进行评估一次.

它们是我建议对您的代码进行的改进，但我也会质疑您的方法：

在第一组嵌套循环中，代码有效地测试了TimeReg_Billable 的A 列中的每个单元格是否与TimeRegistrations_Billable 的W 列中的每个单元格相等 - 85k 行这可能超过 70 亿个循环迭代（！）。

根据您发布的示例表，虽然您可能有 85k 个唯一行，但我认为这两列中的任何一个都没有 85k 个唯一值。因此，我建议

• 在新工作表上使用 Advanced Filter 隔离 O 至 W 列中的唯一值 TimeRegistrations_Billable

• 遍历TimeRegistrations_Billable 的W 列中的每个唯一项，使其成为TimeReg_Billable 的A 列的自动筛选器的过滤条件

• 遍历 TimeReg_Billable 的 A 列中的每个 SpecialCells(xlCellTypeVisible) 并进行所需的更新（必要时使用 .Offset()）

• 你可能会有远的少于 70 亿次循环迭代，并且您无需进行任何测试，因为如果一个单元格是可见单元格之一，那么根据定义，它已经满足测试要求。

您的第二组嵌套循环涉及更多，但广泛使用类似的逻辑，因此我相信您也可以在那里使用过滤来发挥您的优势。