如何解决一张纸达到约 60,000 行后，Excel/VBA 没有响应
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 & ",'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 & ",'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 & ",'Changes'!$A$2:$A$" & lastRowChanges & ",'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'!$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,IF(IFNA(VLOOKUP(RC[-7],'R301F-All Categories (Today-1)'!C[-7],1,FALSE),0)=0,""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 & ",B2,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 & ",A2)-U2,2)"
Set rng11 = rng3.Offset(0,2) 'Flags if Variance or Not. Used for Pivot Tables.
rng11.Formula = "=IF(RC[-1]=0,""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 & ",A2)+SUMIFS('R301 - Booked Same Day'!$I$2:$I$" & lastRowBSD & ",'R301 - Booked Same Day'!$D$2:$D$" & lastRowBSD & ",'R301 - Booked Same Day'!$H$2:$H$" & lastRowBSD & ",'R301 - Booked Same Day'!$A$2:$A$" & lastRowBSD & ",A2)+SUMIFS('Changes'!$E$2:$E$" & 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 & ",A2)-I2,2)"
Set rng14 = rng6.Offset(0,1) 'Flags if Variance or Not. Used for Pivot Tables.
rng14.Formula = "=IF(RC[-1]=0,""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 & ",H2,""<=""&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,IF(IFNA(VLOOKUP(RC[-4],""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 - 所有类别表的 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,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
解决方法
这是对另一个问题中先前答案的重新处理 - 基于使用字典将复合键（来自指定列）映射到来自源数据中另一个指定列的求和值，它是 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,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,4),_
Array(1,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,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,arrKeyCols)'EDIT not Array(1,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
版权声明：本文内容由互联网用户自发贡献，该文观点与技术仅代表作者本人。本站仅提供信息存储空间服务，不拥有所有权，不承担相关法律责任。如发现本站有涉嫌侵权/违法违规的内容， 请发送邮件至 dio@foxmail.com 举报，一经查实，本站将立刻删除。
