Excel/VBA 在一张纸达到约 60,000 行后没有响应

Question

刚接触 VBA，但一直致力于帮助我们更快地平衡系统的项目。代码自 5 月 1 日实施以来一直运行良好，但随着每天添加更多数据，代码变得非常缓慢。现在，在 21 日，代码运行了 30 多分钟才能完成。

代码跨越 5 个工作表，最大列数为 17，最大行数将继续增长到 150,000 左右，但这只是一个估计值。对于提高性能的任何帮助将不胜感激！

Sub Recalculate_Formulas_Section1and2()
   
'Disables settings to speed up code
    Application.ScreenUpdating = False
    Application.DisplayStatusBar = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual
    ActiveWorkbook.AutoSaveOn = False
    
'Test if the value in cell A2 of the Daily Billing Reports is blank/empty
   If IsEmpty(Sheets("Daily Billing Reports").Range("A2").Value) = True Or IsEmpty(Sheets("R301 - All Categories").Range("A2").Value) = True Then
      MsgBox "Import Daily Billing Report and R301 Data to Calculate Section 1 and 2 Variances"
      
      Else
    
'Code to insert validation formulas in Invoice Balancing Template
    Dim lastRowBilling As Long, lastRowR301 As Long, lastRowR301F2 As Long, lastRowBSD As Long, lastRowChanges As Long
    Dim rng1 As Range, rng2 As Range, rng3 As Range, rng4 As Range, rng5 As Range, rng6 As Range, rng7 As Range, rng8 As Range, rng9 As Range
    Dim rng10 As Range, rng11 As Range, rng12 As Range, rng13 As Range, rng14 As Range, rng15 As Range

    'Determine Last Row in Column B (Daily Billing Reports Tab)
    With Worksheets("Daily Billing Reports")
        lastRowBilling = .Range("B" & .Rows.Count).End(xlUp).Row
    End With
    
    'Determine Last Row in Column B (R301F Today-1 Tab)
    With Worksheets("R301F-All Categories (Today-1)")
        lastRowR301F2 = .Range("B" & .Rows.Count).End(xlUp).Row
    End With
    
    'Determine Last Row in Column B (Booked Same Day Tab)
    With Worksheets("R301 - Booked Same Day")
        lastRowBSD = .Range("B" & .Rows.Count).End(xlUp).Row
    End With

    'Determine Last Row in Column B (Changes Tab)
    With Worksheets("Changes")
        lastRowChanges = .Range("B" & .Rows.Count).End(xlUp).Row
    End With

    With Worksheets("R301 - All Categories")
        'Determine last Row in Column B (R301 - All Categories Tab)
        lastRowR301 = .Range("B" & .Rows.Count).End(xlUp).Row

        Set rng1 = .Range("I2:I" & lastRowR301) 'Sums Daily Billing Report revenue and pastes formula value in respective row for column I
        rng1.Formula = "=SUMIFS('Daily Billing Reports'!$N$2:$N$" & lastRowBilling & ",'Daily Billing Reports'!$B$2:$B$" & lastRowBilling & ",D2,'Daily Billing Reports'!$A$2:$A$" & lastRowBilling & ",G2)"

        Set rng2 = rng1.Offset(0, 1) 'Shows the variance between Daily Billing Report revenue and R301 - All Categories revenue
        rng2.Formula = "=ROUND(SUMIFS('R301 - All Categories'!$H$2:$H$" & lastRowR301 & ",'R301 - All Categories'!$D$2:$D$" & lastRowR301 & ",D2,'R301 - All Categories'!$G$2:$G$" & lastRowR301 & ",G2)-I2,2)"

        Set rng9 = rng1.Offset(0, 2) 'Sums R301F-All Categories (Today-1) revenue - Changes
        rng9.Formula = "=SUMIFS('R301F-All Categories (Today-1)'!$H$2:$H$" & lastRowR301F2 & ",'R301F-All Categories (Today-1)'!$D$2:$D$" & lastRowR301F2 & ",D2,'R301F-All Categories (Today-1)'!$G$2:$G$" & lastRowR301F2 & ",G2,'R301F-All Categories (Today-1)'!$A$2:$A$" & lastRowR301F2 & ",A2)-SUMIFS('Changes'!$E$2:$E$" & lastRowChanges & ",'Changes'!$D$2:$D$" & lastRowChanges & ",D2,'Changes'!$A$2:$A$" & lastRowChanges & ",G2,'Changes'!$C$2:$C$" & lastRowChanges & ",A2,'Changes'!$G$2:$G$" & lastRowChanges & ",""<=""&G2)"

        Set rng10 = rng1.Offset(0, 3) 'Shows the variance between Section 1 and Section 2 excluding any changes logged by accounting
        rng10.Formula = "=ROUND(SUMIFS('R301 - All Categories'!$H$2:$H$" & lastRowR301 & ",'R301 - All Categories'!$D$2:$D$" & lastRowR301 & ",D2,'R301 - All Categories'!$G$2:$G$" & lastRowR301 & ",G2,'R301 - All Categories'!$A$2:$A$" & lastRowR301 & ",A2)-K2,2)"

        Set rng12 = rng1.Offset(0, 4) 'Flags if Variance or Not. Used for Pivot Tables.
        rng12.Formula = "=IF(RC[-3]=0,""No"",""Yes"")"
            
        Set rng13 = rng1.Offset(0, 5) 'Flags if Variance or Not but excludes if Day isn't on the R301F-All Categories (Today-1) yet. Used for Pivot Tables.
        rng13.Formula = "=IF(RC[-2]=0,""No"",IF(IFNA(VLOOKUP(RC[-7],'R301F-All Categories (Today-1)'!C[-7],1,FALSE),0)=0,""No"",""Yes""))"
        
        'Drags values entered into column I and N down to bottom of data set
        Range("I2:N" & lastRowR301).Value = Range("I2:N" & lastRowR301).Value
    End With

    With Worksheets("Daily Billing Reports")

        Set rng3 = .Range("U2:U" & lastRowBilling) 'Sums R301 - All Categories revenue
        rng3.Formula = "=SUMIFS('R301 - All Categories'!$H$2:$H$" & lastRowR301 & ",'R301 - All Categories'!$D$2:$D$" & lastRowR301 & ",B2,'R301 - All Categories'!$G$2:$G$" & lastRowR301 & ",A2)"

        Set rng4 = rng3.Offset(0, 1) 'Shows the variance between R301 - All Categories revenue and Daily Billing Report revenue
        rng4.Formula = "=ROUND(SUMIFS('Daily Billing Reports'!$N$2:$N$" & lastRowBilling & ",'Daily Billing Reports'!$B$2:$B$" & lastRowBilling & ",B2,'Daily Billing Reports'!$A$2:$A$" & lastRowBilling & ",A2)-U2,2)"
        
        Set rng11 = rng3.Offset(0, 2) 'Flags if Variance or Not. Used for Pivot Tables.
        rng11.Formula = "=IF(RC[-1]=0,""No"",""Yes"")"
        
        'Drags values entered into column U and W down to bottom of data set
        Range("U2:W" & lastRowBilling).Value = Range("U2:W" & lastRowBilling).Value
    End With
    
    With Worksheets("R301F-All Categories (Today-1)")

        Set rng5 = .Range("I2:I" & lastRowR301F2) 'Sums R301 - All Categories revenue + Booked Same Day revenue + Changes revenue
        rng5.Formula = "=SUMIFS('R301 - All Categories'!$H$2:$H$" & lastRowR301 & ",'R301 - All Categories'!$D$2:$D$" & lastRowR301 & ",D2,'R301 - All Categories'!$G$2:$G$" & lastRowR301 & ",G2,'R301 - All Categories'!$A$2:$A$" & lastRowR301 & ",A2)+SUMIFS('R301 - Booked Same Day'!$I$2:$I$" & lastRowBSD & ",'R301 - Booked Same Day'!$D$2:$D$" & lastRowBSD & ",D2,'R301 - Booked Same Day'!$H$2:$H$" & lastRowBSD & ",G2,'R301 - Booked Same Day'!$A$2:$A$" & lastRowBSD & ",A2)+SUMIFS('Changes'!$E$2:$E$" & lastRowChanges & ",'Changes'!$D$2:$D$" & lastRowChanges & ",D2,'Changes'!$A$2:$A$" & lastRowChanges & ",G2,'Changes'!$C$2:$C$" & lastRowChanges & ",A2,'Changes'!$G$2:$G$" & lastRowChanges & ",""<=""&G2)"

        Set rng6 = rng5.Offset(0, 1) 'Shows the variance between R301F-All Categories (Today-1) revenue + Booked Same Day + Changes and R301 - All Categories
        rng6.Formula = "=ROUND(SUMIFS('R301F-All Categories (Today-1)'!$H$2:$H$" & lastRowR301F2 & ",'R301F-All Categories (Today-1)'!$D$2:$D$" & lastRowR301F2 & ",D2,'R301F-All Categories (Today-1)'!$G$2:$G$" & lastRowR301F2 & ",G2,'R301F-All Categories (Today-1)'!$A$2:$A$" & lastRowR301F2 & ",A2)-I2,2)"
        
        Set rng14 = rng6.Offset(0, 1) 'Flags if Variance or Not. Used for Pivot Tables.
        rng14.Formula = "=IF(RC[-1]=0,""No"",""Yes"")"

        'Drags values entered into column I and K down to bottom of data set
        Range("I2:K" & lastRowR301F2).Value = Range("I2:K" & lastRowR301F2).Value
    End With
        
    With Worksheets("R301 - Booked Same Day")
    If IsEmpty(Sheets("R301 - Booked Same Day").Range("A2").Value) = True Then

    Else
        Set rng7 = .Range("J2:J" & lastRowBSD) 'Sums R301F-All Categories (Today-1) revenue + Changes revenue
        rng7.Formula = "=SUMIFS('R301F-All Categories (Today-1)'!$H$2:$H$" & lastRowR301F2 & ",'R301F-All Categories (Today-1)'!$D$2:$D$" & lastRowR301F2 & ",D2,'R301F-All Categories (Today-1)'!$G$2:$G$" & lastRowR301F2 & ",H2,'R301F-All Categories (Today-1)'!$A$2:$A$" & lastRowR301F2 & ",A2)+SUMIFS('Changes'!$E$2:$E$" & lastRowChanges & ",'Changes'!$D$2:$D$" & lastRowChanges & ",D2,'Changes'!$A$2:$A$" & lastRowChanges & ",H2,'Changes'!$C$2:$C$" & lastRowChanges & ",A2,'Changes'!$G$2:$G$" & lastRowChanges & ",""<=""&G2)"

        Set rng8 = rng7.Offset(0, 1) 'Shows the variance between Booked Same Day revenue + Changes and
        rng8.Formula = "=ROUND(I2-J2,2)"
        
        Set rng15 = rng7.Offset(0, 2) 'Flags if Variance or Not. Used for Pivot Tables.
        rng15.Formula = "=IF(RC[-1]=0,""No"",IF(IFNA(VLOOKUP(RC[-4],'R301F-All Categories (Today-1)'!C[-7],1,FALSE),0)=0,""No"",""Yes""))"

        'Drags values entered into column J and K down to bottom of data set
        Range("J2:L" & lastRowBSD).Value = Range("J2:L" & lastRowBSD).Value
    End If
    End With

'Refreshes Pivot Tables and Formulas after data is copied
    ThisWorkbook.RefreshAll
    Calculate

'Select Section 1-3 Variances Tab of Invoice Balancing Workbook
    Sheets("Section 1-3 Variances").Select

'Enables settings once code is completed
    Application.ScreenUpdating = True
    Application.DisplayStatusBar = True
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
    ActiveWorkbook.AutoSaveOn = True

'Pop up message after process completes
    MsgBox "Process Complete!"
    
End If

End Sub

编辑 1： 尝试使用代码创建复合键，然后 SUMIF 我的原始公式之一，但第四个 With 语句需要一个小时才能执行。关于如何加快 SUMIF 公式的任何想法？

Sub Tester()
    
'Test if the value in cell A2 of the Daily Billing Reports is blank/empty
   If IsEmpty(Sheets("Daily Billing Reports").Range("A2").Value) = True Or IsEmpty(Sheets("R301 - All Categories").Range("A2").Value) = True Then
      MsgBox "Import Daily Billing Report and R301 Data to Calculate Section 1 Variances"
      
      Else
    
'Code to insert validation formulas in Invoice Balancing Template
  
    'Case 2 - temporary "key" column and SUMIF()
    t1 = Timer
    
    With Worksheets("Daily Billing Reports")
    
        'add a temporary "composite key" column to Daily Billing Reports sheet...
        With .Range("U2:U150000")
            .Formula = "=B2 & ""|"" & A2"
            .Value = .Value
        End With
    End With
    
    Debug.Print Timer - t1 '   <1 sec
    
    'Case 2 - temporary "key" column and SUMIF()
    t2 = Timer
    
    With Worksheets("R301 - All Categories")

        'add a temporary "composite key" column to R301 - All Categories sheet...
        With .Range("I2:I150000")
            .Formula = "=D2 & ""|"" & G2"
            .Value = .Value
        End With
    
        'use a SUMIF() on the key column
        With .Range("J2:J150000")
            .Formula = "=SUMIF('Daily Billing Reports'!U2:U150000,I2,'Daily Billing Reports'!N2:N150000)"
            .Value = .Value 'convert to values
        End With
    End With

    Debug.Print Timer - t2 '   About 1 hr
    
    End If
End Sub

编辑 2： 还尝试在数组中构建它，但不确定如何从 arrBillingOut 中减去 arrR301Out 并放置在目标列 11 中。如果可能，还希望将 arrBillingOut 放在 R301 - All Categories 表的 destColR301 中，并将 arrR301Out 放在每日账单报告表的 destColBilling 中.

Sub Tester()

'Code to run Billing Report Values
    Dim arrBilling, wsBilling, rngBilling As Range, keyColsBilling, valueColBilling As Long, destColBilling As Long, iBilling As Long, frmBilling As String, sepBilling As String
    Dim tBilling, dictBilling, arrBillingOut(), arrBillingValues(), vBilling, tmpBilling, nBilling As Long

    keyColsBilling = Array(2, 1)  'these columns form the composite key
    valueColBilling = 14              'column with values (for sum)
    destColBilling = 22               'destination for calculated values
    
    tBilling = Timer
    
    Set wsBilling = Worksheets("Daily Billing Reports")
    Set rngBilling = wsBilling.Range("A1").CurrentRegion
    nBilling = rngBilling.Rows.Count - 1
    Set rngBilling = rngBilling.Offset(1, 0).Resize(nBilling) 'exclude headers
    
    'build the formula to create the row "key"
    For iBilling = 0 To UBound(keyColsBilling)
        frmBilling = frmBilling & sepBilling & rngBilling.Columns(keyColsBilling(iBilling)).Address
        sepBilling = "&""|""&"
    Next iBilling
    arrBilling = wsBilling.Evaluate(frmBilling)  'get an array of composite keys by evaluating the formula
    arrBillingValues = rngBilling.Columns(valueColBilling).Value  'values to be summed
    ReDim arrBillingOut(1 To nBilling, 1 To 1)             'this is for the results
    
    Set dictBilling = CreateObject("scripting.dictionary")
    'first loop over the array counts the keys
    For iBilling = 1 To nBilling
        vBilling = arrBilling(iBilling, 1)
        If Not dictBilling.exists(vBilling) Then dictBilling(vBilling) = Array(0, 0) 'count, sum
        tmpBilling = dictBilling(vBilling) 'can't modify an array stored in a dictionary - pull it out first
        tmpBilling(0) = tmpBilling(0) + 1                 'increment count
        tmpBilling(1) = tmpBilling(1) + arrBillingValues(iBilling, 1)   'increment sum
        dictBilling(vBilling) = tmpBilling                       'return the modified array
    Next iBilling
    
    'second loop populates the output array from the dictionary
    For iBilling = 1 To nBilling
        arrBillingOut(iBilling, 1) = dictBilling(arrBilling(iBilling, 1))(1)  'sumifs
    Next iBilling
'    'populate the results
     rngBilling.Columns(destColBilling).Value = arrBillingOut

    Debug.Print "Checked " & nBilling & " rows in " & Timer - tBilling & " secs"

'Code to run R301 Values
    Dim arrR301, wsR301, rngR301 As Range, keyColsR301, valueColR301 As Long, destColR301 As Long, iR301 As Long, frmR301 As String, sepR301 As String
    Dim tR301, dictR301, arrR301Out(), arrR301Values(), vR301, tmpR301, nR301 As Long

    keyColsR301 = Array(4, 7)  'these columns form the composite key
    valueColR301 = 8              'column with values (for sum)
    destColR301 = 10              'destination for calculated values
    
    tR301 = Timer
    
    Set wsR301 = Worksheets("R301 - All Categories")
    Set rngR301 = wsR301.Range("A1").CurrentRegion
    nR301 = rngR301.Rows.Count - 1
    Set rngR301 = rngR301.Offset(1, 0).Resize(nR301) 'exclude headers
    
    'build the formula to create the row "key"
    For iR301 = 0 To UBound(keyColsR301)
        frmR301 = frmR301 & sepR301 & rngR301.Columns(keyColsR301(iR301)).Address
        sepR301 = "&""|""&"
    Next iR301
    arrR301 = wsR301.Evaluate(frmR301)  'get an array of composite keys by evaluating the formula
    arrR301Values = rngR301.Columns(valueColR301).Value  'values to be summed
    ReDim arrR301Out(1 To nR301, 1 To 1)             'this is for the results
    
    Set dictR301 = CreateObject("scripting.dictionary")
    'first loop over the array counts the keys
    For iR301 = 1 To nR301
        vR301 = arrR301(iR301, 1)
        If Not dictR301.exists(vR301) Then dictR301(vR301) = Array(0, 0) 'count, sum
        tmpR301 = dictR301(vR301) 'can't modify an array stored in a dictionary - pull it out first
        tmpR301(0) = tmpR301(0) + 1                 'increment count
        tmpR301(1) = tmpR301(1) + arrR301Values(iR301, 1)   'increment sum
        dictR301(vR301) = tmpR301                       'return the modified array
    Next iR301
    
    'second loop populates the output array from the dictionary
    For iR301 = 1 To nR301
        arrR301Out(iR301, 1) = dictR301(arrR301(iR301, 1))(1)  'sumifs
    Next iR301
    'populate the results
     rngR301.Columns(destColR301).Value = arrR301Out
       
End Sub

编辑 3： 修改了以下 Tim 的代码，但得到了 RowMap 的 Sub 或 Function not defined 错误。

Sub Tester()
    Dim ws As Worksheet
    Dim t, data, map As Object

    Set ws = Worksheets("Test Daily Billing")
    Set wsR301 = Worksheets("Test R301")

    t = Timer

    data = ws.Range("A2:N40000").Value
    Set map = RowMap(data, Array(2, 1), 14) 'get a summed "map" of the source data
    
    Debug.Print "Built dict", Timer - t

    data = wsR301.Range("A2:H40000").Value
    wsR301.Range("H2:H40000").Value = GetResults(data, map, Array(4, 7)) ' Column H holds the sum value here

    Debug.Print "Done", Timer - t, vbLf

End Sub

Answer 1

这是对另一个问题中先前答案的重新处理 - 它是 SUMIFS() 的更快替代方案，它基于使用字典将复合键（来自指定列）映射到源数据中另一个指定列的总和值.然后可以将该“映射”应用于第二组数据，以便根据匹配的行“键”将总和添加到那里。

Tester 展示了如何应用它（长格式和单行）。其余代码是可重用的函数。

Sub Tester()
    Dim ws As Worksheet
    Dim t, data, map As Object

    Set ws = ActiveSheet

    t = Timer

    data = ws.Range("A2:D100000").Value
    Set map = RowMap(data, Array(1, 2, 3), 4) 'get a summed "map" of the source data

    Debug.Print "Built dict", Timer - t

    data = ws.Range("J2:L1000").Value
    ws.Range("M2:M1000").Value = GetResults(data, map, Array(1, 2, 3))

    Debug.Print "Done", Timer - t, vbLf
    
    'as a one-liner:
    ws.Range("N2:N1000").Value = GetResults(ws.Range("J2:L1000").Value, _
                                         RowMap(ws.Range("A2:D100000").Value, Array(1, 2, 3), 4), _
                                         Array(1, 2, 3))
    
End Sub

'########## below here is all re-usable code..... ###########

'Pass in a dataset, a "map" (dictionary with row "keys" and sums)
'  and an array of column numbers in data to use as composite key
' Return a single-column array with same # of rows as `data`
Function GetResults(data, map, arrKeyCols)
    Dim calcs, r As Long, k
    ReDim calcs(1 To UBound(data, 1), 1 To 1)
    For r = 1 To UBound(data, 1)
        k = RowKey(data, r, arrKeyCols)
        If map.exists(k) Then calcs(r, 1) = map(k)
    Next r
    GetResults = calcs
End Function

'Pass in a data array, an array of column numbers in data to use as composite key,
' and a column number to sum based on the key
' Return a dictionary mapping keys to sums
Function RowMap(data, arrKeyCols, valueCol) As Object 'dictionary
    Dim dict As Object, k As String, r As Long
    Set dict = CreateObject("scripting.dictionary")
    For r = LBound(data) To UBound(data)
        k = RowKey(data, r, arrKeyCols)'EDIT not Array(1, 2, 3)
        dict(k) = dict(k) + data(r, valueCol)
    Next r
    Set RowMap = dict
End Function

'Create a composite key from columns in arrKeyCols
Function RowKey(data, rowNum, arrKeyCols) As String
    Dim rv, i, sep
    For i = LBound(arrKeyCols) To UBound(arrKeyCols)
        rv = rv & sep & data(rowNum, arrKeyCols(i))
        sep = "~~"
    Next i
    RowKey = rv
End Function