加速阵列搜索,如果可能的话,可能是2D收集?

Sub getHours(uniqueArray() As Variant, Lastrow As Integer)

该过程是隐含的 Public ,并隐式传递参数 ByRef .作为维护者,我希望有一个名为 getHours 收到 我的“小时”,不管是什么-但一个 Sub 程序没有 回来 给它的呼叫者的任何东西,比如 Function 做

camelCase 公共程序名称,然后混淆 和 PascalCase 参数名称。坚持 帕斯卡命名法 用于模块成员,并使用 骆驼壳 关于它。

LastRow 成为一名 Integer 升起一面旗帜。 是一个16位有符号整数类型,最大值为32767,当您尝试将其分配到32768或更高时,会出现问题。使用 Long 相反,32位有符号整数类型更适合于通用整数值- 尤其地

Dim i As Integer, lastData As Long

i 长的 和 lastData 已分配,但从未提及-删除它及其分配。说到这里。。。

Sheets("Data").Select
lastData = Range("A2").End(xlDown).Row

.Select 工作表。使用 Worksheet 对象:

Dim dataSheet As Worksheet
Set dataSheet = ThisWorkbook.Worksheets("Data")

请注意 Range 工作表 Me.Range 相反如果没有,则适当地进行资格鉴定 范围 Cells 工作表 对象

lastData = dataSheet.Range("A2").End(xlDown).Row

还有一些整数:

Dim tempTerms As Integer

As Long

Dim OpenForms

openform = DoEvents

您正在分配给 openform ,但您声明 OpenForms Option Explicit 在模块顶部。去做吧。这将阻止VBA愉快地编译拼写错误,并将迫使您声明您使用的每个变量。在这里 未使用,以及 openform 是未申报的 Variant

说实话我都不知道 DoEvents 返回任何东西-它返回的开放形式的数量给我的印象是一个巨大的WTF。无论如何,我一直看到它的使用方式:

DoEvents

这就是全部!是的,这将丢弃返回值。但是,谁首先关心打开的表单的数量呢?

tempProj j 未声明。声明它。

读取单元格的值是危险的。单元格包含 ,因此每当您将单元格的值读入 String 或 或者,无论是什么类型的变量,您都要让VBA执行隐式类型转换——这种转换并不总是可能的。

这将最终打破-或回来咬你在这个或另一个项目:

If tempProj = Cells(j, 10).Value _
And Cells(j, 5).Value = 55 Then
    tempTerms = tempTerms + Cells(j, 8).Value
End If

If IsError(Cells(j, 10).Value) Or IsError(Cells(j, 5).Value) Or IsError(Cells(j, 8).Value) Then
    MsgBox "Row " & j & " contains an error value in column 5, 8, or 10."
    Exit Sub
End If

• 避免 变种
• 避免未声明的变量;他们总是 使用 选项显式
• 避免 Select Activate .
• DoEvents公司 .
• 避免更新UI(状态栏等)。
• 避免访问循环中的工作表单元格。

将工作表的数据读入变量数组:

Dim dataSheet As Worksheet
Set dataSheet = ThisWorkbook.Worksheets("Data")

Dim sheetData As Variant
sheetData = dataSheet.Range("A1:J" & lastData).Value

sheetData 是一个2D数组,包含指定范围内的每个值-所有值在一瞬间复制到内存中。

j 循环变成这样

Dim j As Long
For j = 2 To lastData
    If tempProj = sheetData(j, 10) And sheetData(j, 5) = 55 Then
        tempTerms = tempTerms + sheetData(j, 8)
    End If
Next j

现在我明白你在做什么了。 uniqueArray result 或者更好, outHoursPerTerm

考虑设置 Application.Cursor 然后将其设置回默认值,也可以将状态栏设置为“Please wait…”或类似的内容。 如果 考虑为外部循环的每两次迭代更新状态栏,但请注意,这样做会使过程大大减慢。

在这里,切换计算、工作表事件、屏幕更新等等都不会有什么帮助——你没有在任何地方写作,只有阅读。如果使用内存中的2D阵列,您应该会看到相当大的性能改进。

Code Review

_{未测试,写在答案框中。可能需要将行转换为列。}

将180K行加载到数组中,必须对180K数组进行排序,然后对排序后的数组进行二进制搜索。

Option Explicit

Sub getHours()
  Dim arr1 As Variant, arr2 As Variant
  arr1 = Sheet1.Range("A2:B9001").Value2
  arr2 = Sheet2.Range("A2:J180001").Value2  'whatever your range is

  QuickSort1 arr2, 10   'sorting data on column 10 as you had it.

  Dim i As Long, j As Long, tempSum As Long

  For i = 1 To UBound(arr1)
        tempSum = 0

        Dim retArr As Variant
        retArr = wsArrayBinaryLookup(arr1(i, 1), arr2, 10, 10, False)
        If Not IsError(retArr(0)) Then
        If arr1(i, 1) = retArr(0) Then
              Dim matchRow As Long
              matchRow = retArr(1)
              'Go through from matched row till stop matching
              Do
                    If arr2(matchRow, 10) <> arr1(i, 1) Then Exit Do
                    If arr2(matchRow, 5) = 55 Then
                          tempSum = tempSum + arr2(matchRow, 8)
                    End If
                    matchRow = matchRow + 1
              Loop While matchRow <= UBound(arr2)
        End If
        End If
        arr1(i, 2) = tempSum
        DoEvents
  Next i

  Sheet1.Range("A2:B9001").Value2 = arr1
End Sub

Public Sub QuickSort1( _
                       ByRef pvarArray As Variant, _
                       ByVal colToSortBy, _
                       Optional ByVal plngLeft As Long, _
                       Optional ByVal plngRight As Long)
  Dim lngFirst As Long
  Dim lngLast As Long
  Dim varMid As Variant
  Dim varSwap As Variant

  If plngRight = 0 Then
        plngLeft = LBound(pvarArray)
        plngRight = UBound(pvarArray)
  End If

  lngFirst = plngLeft
  lngLast = plngRight
  varMid = pvarArray((plngLeft + plngRight) \ 2, colToSortBy)

  Do
        Do While pvarArray(lngFirst, colToSortBy) < varMid And lngFirst < plngRight
              lngFirst = lngFirst + 1
        Loop

        Do While varMid < pvarArray(lngLast, colToSortBy) And lngLast > plngLeft
              lngLast = lngLast - 1
        Loop

        Dim arrColumn As Long
        If lngFirst <= lngLast Then
              For arrColumn = 1 To UBound(pvarArray, 2)
                    varSwap = pvarArray(lngFirst, arrColumn)
                    pvarArray(lngFirst, arrColumn) = pvarArray(lngLast, arrColumn)
                    pvarArray(lngLast, arrColumn) = varSwap
              Next arrColumn
              lngFirst = lngFirst + 1
              lngLast = lngLast - 1
        End If

  Loop Until lngFirst > lngLast

  If plngLeft < lngLast Then QuickSort1 pvarArray, colToSortBy, plngLeft, lngLast
  If lngFirst < plngRight Then QuickSort1 pvarArray, colToSortBy, lngFirst, plngRight
End Sub

Public Function wsArrayBinaryLookup( _
               ByVal val As Variant, _
               arr As Variant, _
               ByVal searchCol As Long, _
               ByVal returnCol As Long, _
               Optional exactMatch As Boolean = True) As Variant

  Dim a As Long, z As Long, curr As Long
  Dim retArr(0 To 1) As Variant

  retArr(0) = CVErr(xlErrNA)
  retArr(1) = 0
  wsArrayBinaryLookup = retArr
  a = LBound(arr)
  z = UBound(arr)


  If compare(arr(a, searchCol), val) = 1 Then
        Exit Function
  End If

  If compare(arr(a, searchCol), val) = 0 Then
        retArr(0) = arr(a, returnCol)
        retArr(1) = a
        wsArrayBinaryLookup = retArr
        Exit Function
  End If

  If compare(arr(z, searchCol), val) = -1 Then
        Exit Function
  End If

  While z - a > 1
        curr = Round((CLng(a) + CLng(z)) / 2, 0)
        If compare(arr(curr, searchCol), val) = 0 Then
              z = curr
              retArr(0) = arr(curr, returnCol)
              retArr(1) = curr
              wsArrayBinaryLookup = retArr
        End If

        If compare(arr(curr, searchCol), val) = -1 Then
              a = curr
        Else
              z = curr
        End If
  Wend

  If compare(arr(z, searchCol), val) = 0 Then
        retArr(0) = arr(z, returnCol)
        retArr(1) = z
        wsArrayBinaryLookup = retArr
  Else
        If Not exactMatch Then
              retArr(0) = arr(a, returnCol)
              retArr(1) = a
              wsArrayBinaryLookup = retArr
        End If
  End If


End Function
Public Function compare(ByVal x As Variant, ByVal y As Variant) As Long

  If IsNumeric(x) And IsNumeric(y) Then
        Select Case x - y
              Case Is = 0
                    compare = 0
              Case Is > 0
                    compare = 1
              Case Is < 0
                    compare = -1
        End Select
  Else
        If TypeName(x) = "String" And TypeName(y) = "String" Then
              compare = StrComp(x, y, vbTextCompare)
        End If
  End If

End Function

这是我通常用来超速的:

Public Sub OnEnd()    
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.AskToUpdateLinks = True
    Application.DisplayAlerts = True
    Application.Calculation = xlAutomatic
    ThisWorkbook.Date1904 = False        
    Application.StatusBar = False        
End Sub

Public Sub OnStart()        
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.AskToUpdateLinks = False
    Application.DisplayAlerts = False
    Application.Calculation = xlAutomatic
    ThisWorkbook.Date1904 = False        
    ActiveWindow.View = xlNormalView    
End Sub

Sub getHours(uniqueArray() As Variant, Lastrow As Integer)
    Dim i As Integer, lastData As Long
    Dim tempTerms As Integer
    Dim OpenForms

    call OnStart
    code ...

    Next i

    call OnEnd

End Sub

这个 ScreenUpdating = False 完成大约90%的工作,其余的只是为了确保它按预期运行。

编辑: Dim tempTerms As Integer 到 Long 它应该更快。也许最好定义一下 OpenForms