Question

我需要一些帮助来加速我正在运行的当前代码。

首先，我有一张大data张，大约有180,000行，还有一张unique张，其中只包含该大型列表中的唯一值，大约为9000行，因此目前需要这个代码可行的时间太长了。当前i和j值只是占位符，用于测试代码是否正常工作。

我有想创建一个集合来存储数据，这样一旦匹配，它就可以从集合中删除，因此以后不需要再次检查uniqueArray()中的其他值。。

是否可以收集，因为我需要在添加第4个单元格的值之前检查3个条件？

我非常感谢任何帮助或建议，因为我真的只是在VBA中编程了几个星期。

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

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

    For i = 1 To Lastrow
        uniqueArray(i, 2) = 0
    Next i
    i = 0

    For i = 1 To 10 'Lastrow

        tempTerms = 0
        tempProj = uniqueArray(i, 1)

        If i Mod 30 = 0 Then
            openform = DoEvents
        End If

        For j = 2 To 10000  'lastData
            If tempProj = Cells(j, 10).Value _
            And Cells(j, 5).Value = 55 Then
                tempTerms = tempTerms + Cells(j, 8).Value
            End If
        Next j

    uniqueArray(i, 2) = tempTerms
    Application.StatusBar = i

    Next i


End Sub

Answer 1

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

该过程隐含Public，参数隐式传递ByRef。作为一个维护者，我希望一个名为getHours的方法我<＆＃34;小时＆＃34;，无论是什么 - 但是Sub程序没有＆＃39}。 t 向其来电者返回任何内容，就像Function一样。因此该名称具有误导性。程序做某些东西，它们需要一个描述它的功能的描述性名称，然后代码需要按照名称所说的去做。

一致性也很重要：您拥有camelCase公共过程名称，然后是混合的camelCase和PascalCase参数名称。坚持PascalCase模块成员，并使用camelCase作为本地/参数。或者其他 - 只是一致。

LastRow成为Integer会举起一面旗帜。 Integer是一个16位有符号整数类型，其最大值为32,767，当您尝试将其分配给32,768或更高时会导致问题。使用Long代替 - 一个32位有符号整数类型更适合于通用整数值 - 尤其类似于＆＃34;行号＆＃34;，它可以在Excel中远远超过100K。

Dim i As Integer, lastData As Long

i应该是Long，并且lastData已分配，但从未提及 - 删除它及其分配。说到哪......

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

不要.Select工作表。改为使用Worksheet对象：

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

请注意，对于Range对象不合格的Worksheet隐式引用任何工作表处于活动状态，无论哪个工作簿处于活动状态。除非您在工作表模块的代码隐藏中 - 在这种情况下，它指的是该工作表。如果您的意思是这样做，请明确并改为Me.Range。如果没有，则使用Range对象正确限定Cells和Worksheet次来电。

然后使用它：

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

更多整数：

Dim tempTerms As Integer

再次，没有理由使用16位整数类型，声明As Long。

Dim OpenForms

这个程序需要知道开放表格的数量是多少？它没有。删除它。

openform = DoEvents

您已分配给openform，但您声明了OpenForms。如果您的代码编译并运行，则表示您尚未在模块顶部指定Option Explicit。做吧。这将阻止VBA愉快地编译拼写错误，并将强制您声明您使用的每个变量。此处OpenForms未使用，openform是VBA运行时即时声明的未声明Variant。

说实话，我甚至都不知道DoEvents返回任何东西 - 它返回了开放形式的数量，这让我感觉像是一个巨大的WTF。无论如何，我总是看到它如何使用：

DoEvents

这就是全部！是的，这会丢弃返回的值。但谁首先关心开放表格的数量？

tempProj未声明。宣布它。 j未声明。声明它。

读取单元格的值很危险。单元格包含Variant，因此每当您将单元格的值读入String或Long或任何类型变量时，您都会使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

好的，那么性能呢？

如果存在更好的类型，请避免使用Variant。
避免未声明的变量;他们总是Variant。使用Option Explicit。
避免隐式类型转换。
避免使用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设置为沙漏并在完成后将其设置为默认值 - 可能还要将状态栏设置为＆＃34;请稍候...＆＃34;或类似的东西。如果事情需要超过5-8秒，那么然后考虑更新外部循环的每次迭代的状态栏，但请注意，这样做会使程序显着慢。

切换计算，工作表事件，屏幕更新等等，在这里没有帮助 - 你不是在任何地方写作，只是阅读。解决内存中的2D阵列问题，您应该会看到相当大的性能提升。

这个答案故意像Code Review一样回答。关于改进工作代码（性能，可读性等）的问题通常更适合CR。下次在需要帮助改进工作代码时考虑询问CR - 正如您可以看到CR答案涵盖的内容远远超过典型的SO答案。

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

Answer 2

这是我通常用于超速的：

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定义为某种东西。

Answer 3

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

对于外循环的每次迭代使用匹配行的备忘录，然后在匹配完成后停止在内循环上测试条件。轻松完成界面更新。

每次外部迭代的Doevents都可以通过。只需转储下面的适当功能：

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

如果可能的话，加速数组搜索，可能是2D Collection

3 个答案:

好的，那么性能呢？