Excel‘大’数据处理跟踪
Excel‘大’数据处理跟踪
提问于 2017-03-22 17:59:47
上一个问题(初始级别优化)：Excel“大”数据处理与查找“
代码用途:根据新信息(由不同的宏提供)重新计算每列500 000行的25列。之前的线程运行了28个小时，现在需要8个小时，我的目标是低于3。
备注
- 我们计划将这一过程转化为一个旨在保存这么多数据的程序，但是IT和其他专家在接下来的7个月里都忙于更高优先级的项目。我需要在下个月底，当这类产品再次上市时，才能开始运行。
- 用户拥有32位Excel以及随之而来的所有限制。我有64位。目前它大约需要半个任务才能运行。
- 报告必须每天早上10:00之前运行，这就是为什么我的目标是3小时。目前的运行时间为8小时，如果它能够在早上自动运行，则是可行的，但我不知道如何实现这种过程。
- 我使用VBA还不到一年，也没有使用SQL或数组的经验。我知道这些项目可能有助于缩短时间，但我需要一些关于如何实施它们和我应该往哪个方向去的指导。我读过几篇关于每一篇文章的文章，所以我理解了它们如何工作的基本原理，如果您能告诉我具体的函数，我将非常感谢它们的相关限制。
- 主循环是从"For i=2到lrMain“到末尾的所有内容。在此之前，我只需3分钟就能完成任务，这对我来说并不是一个优化问题。
- 此工作簿中任何地方都没有计算单元格，因此禁用计算不会节省时间。
- 此时重构原始数据是不合理的，但是写入新的工作表或文件并不是一个问题。
- 我非常感谢一切帮助。
在模块顶部：
Dim velocityLookup As Scripting.Dictionary
Const Velocity_Key_Col As Long = 10
Option Explicit由共产国际构建的BuildVelocityLookup子
Sub BuildVelocityLookup(target As Worksheet, keyCol As Long, lookup As Scripting.Dictionary)
Set lookup = New Scripting.Dictionary
With target
Dim lastRow As Long
lastRow = .Cells.Find(What:="*", SearchOrder:=xlByRows, Searchdirection:=xlPrevious).Row
Dim keys As Variant
keys = .Range(.Cells(2, keyCol), .Cells(lastRow, keyCol)).Value
Dim j As Long
For j = LBound(keys) To UBound(keys)
'Note that the row is offset from the array.
keys(j, 1) = UCase(keys(j, 1))
lookup.Add keys(j, 1), j + 1
Next
End With
End Sub由艾米丽·奥尔登撰写的Calculate_Click与共产国际的改进
Sub Calculate_Click()
'******************* Insert a line to freeze screen here.
Dim wsMain As Worksheet
Dim wsQuantity As Worksheet
Dim wsVelocity As Worksheet
Dim wsParameters As Worksheet
Dim wsData As Worksheet
Dim lrMain As Long 'lr = last row
Dim lrQuantity As Long
Dim lrVelocity As Long
Dim lrParameters As Long
Dim lrData As Long
Dim i As Long 'Row Counter
'For Optimization Testing Only.
Dim MainTimer As Double
MainTimer = Timer
Set wsMain = Worksheets("Main Tab")
Set wsQuantity = Worksheets("Quantity Available")
Set wsVelocity = Worksheets("Velocity")
Set wsParameters = Worksheets("Parameters")
Set wsData = Worksheets("Data Input by Account")
lrMain = wsMain.Cells.Find(What:="*", SearchOrder:=xlByRows, Searchdirection:=xlPrevious).Row
lrQuantity = wsQuantity.Cells.Find(What:="*", SearchOrder:=xlByRows, Searchdirection:=xlPrevious).Row
lrVelocity = wsVelocity.Cells.Find(What:="*", SearchOrder:=xlByRows, Searchdirection:=xlPrevious).Row
lrParameters = wsParameters.Cells.Find(What:="*", SearchOrder:=xlByRows, Searchdirection:=xlPrevious).Row
lrData = wsData.Cells.Find(What:="*", SearchOrder:=xlByRows, Searchdirection:=xlPrevious).Row
Dim calcWeek As Long
calcWeek = wsParameters.Range("B3").Value
For i = 2 To 5 'lrQuantity
With wsQuantity
.Cells(i, 5) = .Cells(i, 1) & .Cells(i, 2)
.Cells(i, 6) = .Cells(i, 1) & UCase(.Cells(i, 2).Value) & .Cells(i, 3)
End With
Next i
wsData.Range(wsData.Cells(2, 1), wsData.Cells(lrData, 4)).Sort _
key1:=wsData.Range("A2"), order1:=xlAscending, Header:=xlNo
Dim tempLookup As Variant
For i = 2 To 5 'lrData
tempLookup = Application.VLookup(wsData.Cells(i, 2), wsParameters.Range("Table5"), 2, False)
If IsError(tempLookup) Then
wsData.Cells(i, 3).Value = "Missing"
Else
wsData.Cells(i, 3).Value = tempLookup
End If
Next i
For i = 2 To 5 'lrVelocity
With wsVelocity
.Cells(i, 10) = .Cells(i, 1) & .Cells(i, 4) & .Cells(i, 5) & .Cells(i, 9)
.Cells(i, 10).Value = CStr(Trim(.Cells(i, 10).Value))
.Cells(i, 11) = .Cells(i, 6)
.Cells(i, 12) = .Cells(i, 7)
.Cells(i, 13) = .Cells(i, 8)
.Cells(i, 14) = .Cells(i, 3)
.Cells(i, 22) = .Cells(i, 1) & .Cells(i, 9)
End With
Next i
wsVelocity.Range(wsVelocity.Cells(2, 1), wsVelocity.Cells(lrVelocity, 10)).Sort _
key1:=wsVelocity.Range("J2"), order1:=xlAscending, Header:=xlNo
BuildVelocityLookup wsVelocity, Velocity_Key_Col, velocityLookup
Dim indexVelocity1 As Range
Dim indexVelocity2 As Range
Dim matchVelocity1 As Range
Dim matchVelocity2 As Range
With wsVelocity
Set indexVelocity1 = .Range(.Cells(2, 7), .Cells(lrVelocity, 7))
Set indexVelocity2 = .Range(.Cells(2, 3), .Cells(lrVelocity, 3))
Set matchVelocity1 = .Range(.Cells(2, 1), .Cells(lrVelocity, 1))
Set matchVelocity2 = .Range(.Cells(2, 22), .Cells(lrVelocity, 22))
End With
Dim indexQuantity As Range
Dim matchQuantity As Range
With wsQuantity
Set indexQuantity = .Range(.Cells(2, 4), .Cells(lrQuantity, 4))
Set matchQuantity = .Range(.Cells(2, 6), .Cells(lrQuantity, 6))
End With
Dim ShipMin As Long
ShipMin = wsParameters.Cells(7, 2).Value
wsMain.Activate
With wsMain
.Range(.Cells(2, 9), .Cells(lrMain, 20)).ClearContents
.Range(.Cells(2, 22), .Cells(lrMain, 47)).ClearContents
End With
For i = 2 To lrMain
With wsMain
Dim conUD As String 'con=concatenate
conUD = .Cells(i, 21) & .Cells(i, 4) & calcWeek
.Cells(i, 21) = .Cells(i, 5) & .Cells(i, 3)
If .Cells(i, 8) <> 0 Then
.Cells(i, 9) = .Cells(i, 6) / .Cells(i, 8)
End If
Dim velocityRow As Long
If velocityLookup.Exists(conUD) Then
velocityRow = velocityLookup.Item(conUD)
tempLookup = wsVelocity.Cells(velocityRow, 11)
End If
.Cells(i, 10).Value = tempLookup
tempLookup = wsVelocity.Cells(velocityRow, 14)
.Cells(i, 11).Value = tempLookup
If .Cells(i, 9) > .Cells(i, 11) Then
.Cells(i, 12).Value = Round((.Cells(i, 6) / .Cells(i, 11)) / .Cells(i, 10), 0.1)
End If
If .Cells(i, 6) > 0 Then
If .Cells(i, 12) <> "" Then
.Cells(i, 13).Value = .Cells(i, 12) - .Cells(i, 8)
End If
End If
Dim conECD As String
conECD = .Cells(i, 5) & .Cells(i, 3) & .Cells(i, 4) & calcWeek
If velocityLookup.Exists(conECD) Then
velocityRow = velocityLookup.Item(conECD)
tempLookup = wsVelocity.Cells(velocityRow, 12)
End If
If .Cells(i, 13) <> "" Then
If tempLookup <> 0 Then
.Cells(i, 14).Value = Int(.Cells(i, 13) / tempLookup)
End If
End If
If velocityLookup.Exists(conECD) Then
velocityRow = velocityLookup.Item(conECD)
tempLookup = wsVelocity.Cells(velocityRow, 13)
End If
If .Cells(i, 14) > tempLookup Then
If .Cells(i, 14) <> "" Then
.Cells(i, 15).Value = tempLookup
End If
Else
.Cells(i, 15).Value = .Cells(i, 14).Value
End If
If .Cells(i, 14) = "" Then
If .Cells(i, 11) = "" Then
.Cells(i, 26) = ""
Else
.Cells(i, 26).Value = Round(.Cells(i, 14).Value * .Cells(i, 11).Value, 0)
End If
End If
tempLookup = Application.Index(indexQuantity, Application.Match((.Cells(i, 21).Value & "LIBERTY") _
, matchQuantity, False))
.Cells(i, 24).Value = tempLookup
.Cells(i, 18).Value = .Cells(i, 24) - Application.SumIf(.Range(.Cells(1, 21), .Cells(i, 21)), _
.Cells(i, 21).Value, .Range(.Cells(1, 26), .Cells(i, 26)))
If velocityLookup.Exists(conUD) Then
velocityRow = velocityLookup.Item(conUD)
tempLookup = wsVelocity.Cells(velocityRow, 13)
End If
If .Cells(i, 26) > tempLookup Then
.Cells(i, 28).Value = tempLookup
Else
.Cells(i, 28).Value = .Cells(i, 26).Value
End If
If .Cells(i, 18).Value < 0 Then
.Cells(i, 29).Value = "C"
.Cells(i, 27).Value = ""
Else
.Cells(i, 27) = .Cells(i, 28)
End If
.Cells(i, 31).Value = Application.SumIf(.Range(.Cells(2, 1), .Cells(lrMain, 1)), _
.Cells(i, 1).Value, .Range(.Cells(2, 27), .Cells(lrMain, 27)))
If .Cells(i, 5) = "" Then
.Cells(i, 35) = ""
Else
.Cells(i, 35).Value = Application.Index(indexVelocity1, _
Application.Match(.Cells(i, 5), matchVelocity1, False))
End If
If .Cells(i, 6).Value = 0 Then
.Cells(i, 44).Value = 0
Else
.Cells(i, 44).Value = Round(((((.Cells(i, 6).Value / .Cells(i, 11).Value) _
/ .Cells(i, 10).Value) - .Cells(i, 8).Value) / .Cells(i, 35).Value), 0.1)
End If
If .Cells(i, 6).Value = 0 Then
.Cells(i, 34).Value = 0
.Cells(i, 33) = 0
Else
.Cells(i, 34).Value = Round(((((.Cells(i, 6) / .Cells(i, 11)) / _
.Cells(i, 10)) - .Cells(i, 8)) / .Cells(i, 35)) * .Cells(i, 11), 0.1)
If .Cells(i, 34) > 0 Then
.Cells(i, 33) = .Cells(i, 34)
Else
.Cells(i, 33) = 0
End If
End If
.Cells(i, 37) = 1 + calcWeek
.Cells(i, 38) = .Cells(i, 5) & .Cells(i, 37)
.Cells(i, 39).Value = Application.Index(indexVelocity2, _
Application.Match(.Cells(i, 38), matchVelocity2, False))
.Cells(i, 40) = Round(((((.Cells(i, 6) / .Cells(i, 11)) * .Cells(i, 39)) _
- .Cells(i, 6)) - (.Cells(i, 8) - .Cells(i, 6))) / .Cells(i, 35), 0.1)
If .Cells(i, 40) < 0 Then
.Cells(i, 41) = 0
Else
.Cells(i, 41) = .Cells(i, 40)
End If
.Cells(i, 42) = .Cells(i, 41) - .Cells(i, 33)
If .Cells(i, 11) < .Cells(1, 44) Then
.Cells(i, 45) = 0
.Cells(i, 32) = .Cells(i, 45)
Else
.Cells(i, 32) = Application.Max(.Cells(i, 33), .Cells(i, 41))
If .Cells(i, 44) < 0 Then
.Cells(i, 45) = ""
Else
.Cells(i, 45) = .Cells(i, 44)
End If
End If
If .Cells(i, 31) < ShipMin Then
.Cells(i, 47) = 0
Else
.Cells(i, 47) = .Cells(i, 27)
End If
.Cells(i, 46) = .Cells(i, 1) & .Cells(i, 22) & .Cells(i, 47)
End With
If (i Mod 100) = 0 Then
Debug.Print "Got to row "; i; " in "; Timer - MainTimer; " seconds."
End If
Next i
End Sub回答 3
Code Review用户
回答已采纳
发布于 2017-03-22 18:53:52
我试着修改您的代码，以便为此使用数组(可能有人比我快到了)。我对旧代码进行了注释，这样您就可以看到正在发生的事情的逻辑：
Sub Calculate_Click()
'******************* Insert a line to freeze screen here.
Dim wsMain As Worksheet
Dim wsQuantity As Worksheet
Dim wsVelocity As Worksheet
Dim wsParameters As Worksheet
Dim wsData As Worksheet
Dim lrMain As Long 'lr = last row
Dim lrQuantity As Long
Dim lrVelocity As Long
Dim lrParameters As Long
Dim lrData As Long
Dim i As Long 'Row Counter
'For Optimization Testing Only.
Dim MainTimer As Double
MainTimer = Timer
Set wsMain = Worksheets("Main Tab")
Set wsQuantity = Worksheets("Quantity Available")
Set wsVelocity = Worksheets("Velocity")
Set wsParameters = Worksheets("Parameters")
Set wsData = Worksheets("Data Input by Account")
lrMain = wsMain.Cells.Find(What:="*", SearchOrder:=xlByRows, Searchdirection:=xlPrevious).Row
lrQuantity = wsQuantity.Cells.Find(What:="*", SearchOrder:=xlByRows, Searchdirection:=xlPrevious).Row
lrVelocity = wsVelocity.Cells.Find(What:="*", SearchOrder:=xlByRows, Searchdirection:=xlPrevious).Row
lrParameters = wsParameters.Cells.Find(What:="*", SearchOrder:=xlByRows, Searchdirection:=xlPrevious).Row
lrData = wsData.Cells.Find(What:="*", SearchOrder:=xlByRows, Searchdirection:=xlPrevious).Row
Dim calcWeek As Long
calcWeek = wsParameters.Range("B3").Value
For i = 2 To 5 'lrQuantity
With wsQuantity
.Cells(i, 5) = .Cells(i, 1) & .Cells(i, 2)
'Removed .Value to keep things consistent
.Cells(i, 6) = .Cells(i, 1) & UCase(.Cells(i, 2)) & .Cells(i, 3)
End With
Next i
wsData.Range(wsData.Cells(2, 1), wsData.Cells(lrData, 4)).Sort _
key1:=wsData.Range("A2"), order1:=xlAscending, Header:=xlNo
Dim tempLookup As Variant
For i = 2 To 5 'lrData
tempLookup = Application.VLookup(wsData.Cells(i, 2), wsParameters.Range("Table5"), 2, False)
If IsError(tempLookup) Then
wsData.Cells(i, 3).Value = "Missing"
Else
wsData.Cells(i, 3).Value = tempLookup
End If
Next i
For i = 2 To 5 'lrVelocity
With wsVelocity
' Combined reformatting into one line
.Cells(i, 10) = CStr(Trim(.Cells(i, 1) & .Cells(i, 4) & .Cells(i, 5) & .Cells(i, 9)))
.Cells(i, 11) = .Cells(i, 6)
.Cells(i, 12) = .Cells(i, 7)
.Cells(i, 13) = .Cells(i, 8)
.Cells(i, 14) = .Cells(i, 3)
.Cells(i, 22) = .Cells(i, 1) & .Cells(i, 9)
End With
Next i
wsVelocity.Range(wsVelocity.Cells(2, 1), wsVelocity.Cells(lrVelocity, 10)).Sort _
key1:=wsVelocity.Range("J2"), order1:=xlAscending, Header:=xlNo
BuildVelocityLookup wsVelocity, Velocity_Key_Col, velocityLookup
Dim indexVelocity1 As Range
Dim indexVelocity2 As Range
Dim matchVelocity1 As Range
Dim matchVelocity2 As Range
With wsVelocity
Set indexVelocity1 = .Range(.Cells(2, 7), .Cells(lrVelocity, 7))
Set indexVelocity2 = .Range(.Cells(2, 3), .Cells(lrVelocity, 3))
Set matchVelocity1 = .Range(.Cells(2, 1), .Cells(lrVelocity, 1))
Set matchVelocity2 = .Range(.Cells(2, 22), .Cells(lrVelocity, 22))
End With
Dim indexQuantity As Range
Dim matchQuantity As Range
With wsQuantity
Set indexQuantity = .Range(.Cells(2, 4), .Cells(lrQuantity, 4))
Set matchQuantity = .Range(.Cells(2, 6), .Cells(lrQuantity, 6))
End With
Dim ShipMin As Long
ShipMin = wsParameters.Cells(7, 2).Value
wsMain.Activate ' Why? No need to activate here.
With wsMain
.Range(.Cells(2, 9), .Cells(lrMain, 20)).ClearContents
.Range(.Cells(2, 22), .Cells(lrMain, 47)).ClearContents
End With
Dim arrHolder As Variant
' Check the indices on this. I did my best to assume them using the code.
arrHolder = .Range(wsMain.Cells(2, 1), wsMain.Cells(lrMain, 47))
'For i = 2 To lrMain
' This likely will break cell calculations, but works with the array just fine.
For i = LBound(arrHolder) To lrMain
With wsMain
Dim conUD As String 'con=concatenate
'conUD = .Cells(i, 21) & .Cells(i, 4) & calcWeek
conUD = arrHolder(i, 21) & arrHolder(i, 4) & calcWeek
'.Cells(i, 21) = .Cells(i, 5) & .Cells(i, 3)
arrHolder(i, 21) = arrHolder(i, 5) & arrHolder(i, 3)
'If .Cells(i, 8) <> 0 Then
' .Cells(i, 9) = .Cells(i, 6) / .Cells(i, 8)
'End If
If arrHolder(i, 8) <> 0 Then
arrHolder(i, 9) = arrHolder(i, 6) / arrHolder(i, 8)
End If
Dim velocityRow As Long
If velocityLookup.Exists(conUD) Then
velocityRow = velocityLookup.Item(conUD)
tempLookup = wsVelocity.Cells(velocityRow, 11)
End If
'.Cells(i, 10).Value = tempLookup
arrHolder(i, 10) = tempLookup
tempLookup = wsVelocity.Cells(velocityRow, 14)
'.Cells(i, 11).Value = tempLookup
arrHolder(i, 11) = tempLookup
'If .Cells(i, 9) > .Cells(i, 11) Then
' .Cells(i, 12).Value = Round((.Cells(i, 6) / .Cells(i, 11)) / .Cells(i, 10), 0.1)
'End If
If arrHolder(i, 9) > arrHolder(i, 11) Then
arrHolder(i, 12) = Round((arrHolder(i, 6) / arrHolder(i, 11)) / arrHolder(i, 10), 0.1)
End If
'If .Cells(i, 6) > 0 Then
' If .Cells(i, 12) <> "" Then
' .Cells(i, 13).Value = .Cells(i, 12) - .Cells(i, 8)
' End If
'End If
If arrHolder(i, 6) > 0 Then
If arrHolder(i, 12) <> vbNullString Then
arrHolder(i, 13) = arrHolder(i, 12) - arrHolder(i, 8)
End If
End If
Dim conECD As String
'conECD = .Cells(i, 5) & .Cells(i, 3) & .Cells(i, 4) & calcWeek
conECD = arrHolder(i, 5) & arrHolder(i, 3) & arrHolder(i, 4) & calcWeek
' It looks like you use this block a few times with different variables. Consider extracting to a function
If velocityLookup.Exists(conECD) Then
velocityRow = velocityLookup.Item(conECD)
tempLookup = wsVelocity.Cells(velocityRow, 12)
End If
'If .Cells(i, 13) <> "" Then
' If tempLookup <> 0 Then
' .Cells(i, 14).Value = Int(.Cells(i, 13) / tempLookup)
' End If
'End If
If arrHolder(i, 13) <> vbNullString Then
If tempLookup <> 0 Then
arrHolder(i, 14) = Int(arrHolder(i, 13) / tempLookup)
End If
End If
If velocityLookup.Exists(conECD) Then
velocityRow = velocityLookup.Item(conECD)
tempLookup = wsVelocity.Cells(velocityRow, 13)
End If
'If .Cells(i, 14) > tempLookup Then
' If .Cells(i, 14) <> "" Then
' .Cells(i, 15).Value = tempLookup
' End If
'Else
' .Cells(i, 15).Value = .Cells(i, 14).Value
'End If
If arrHolder(i, 14) > tempLookup Then
If arrHolder(i, 14) <> vbNullString Then
arrHolder(i, 15) = tempLookup
End If
Else
arrHolder(i, 15) = arrHolder(i, 14)
End If
'If .Cells(i, 14) = "" Then
' If .Cells(i, 11) = "" Then
' .Cells(i, 26) = ""
' Else
' .Cells(i, 26).Value = Round(.Cells(i, 14).Value * .Cells(i, 11).Value, 0)
' End If
'End If
If arrHolder(i, 14) = vbNullString Then
If arrHolder(i, 11) = vbNullString Then
arrHolder(i, 26) = vbNullString
Else
arrHolder(i, 26) = Round(arrHolder(i, 14) * arrHolder(i, 11), 0)
End If
End If
'tempLookup = Application.Index(indexQuantity, Application.Match((.Cells(i, 21).Value & "LIBERTY") _
' , matchQuantity, False))
tempLookup = Application.Index(indexQuantity, Application.Match((arHolder(i, 21) & "LIBERTY") _
, matchQuantity, False))
'.Cells(i, 24).Value = tempLookup
arrHolder(i, 24) = tempLookup
' I havent used application SumIf on an array before, so I instead edited this so it should use the correct index value.
' This will likely not work as I want it to, so it may just need to go into a separate loop or something.
' .Cells(i, 18).Value = .Cells(i, 24) - Application.SumIf(.Range(.Cells(1, 21), .Cells(i, 21)), _
' .Cells(i, 21).Value, .Range(.Cells(1, 26), .Cells(i, 26)))
arrHolder(i, 18) = .Cells(i + 1, 24) - Application.SumIf(.Range(.Cells(1, 21), .Cells(i + 1, 21)), _
.Cells(i + 1, 21).Value, .Range(.Cells(1, 26), .Cells(i + 1, 26)))
If velocityLookup.Exists(conUD) Then
velocityRow = velocityLookup.Item(conUD)
tempLookup = wsVelocity.Cells(velocityRow, 13)
End If
'If .Cells(i, 26) > tempLookup Then
' .Cells(i, 28).Value = tempLookup
'Else
' .Cells(i, 28).Value = .Cells(i, 26).Value
'End If
If arrHolder(i, 26) > tempLookup Then
arrHolder(i, 28) = tempLookup
Else
arrHolder(i, 28) = arrHolder(i, 26)
End If
'If .Cells(i, 18).Value < 0 Then
' .Cells(i, 29).Value = "C"
' .Cells(i, 27).Value = ""
'Else
' .Cells(i, 27) = .Cells(i, 28)
'End If
If arrHolder(i, 18) < 0 Then
arrHolder(i, 29) = "C"
arrHolder(i, 27) = vbNullString
Else
arrHolder(i, 27) = arrHolder(i, 28)
End If
'.Cells(i, 31).Value = Application.SumIf(.Range(.Cells(2, 1), .Cells(lrMain, 1)), _
' .Cells(i, 1).Value, .Range(.Cells(2, 27), .Cells(lrMain, 27)))
' Another SumIf. Same as before, we will have to figure this out separately.
arrHolder(i, 31) = Application.SumIf(.Range(.Cells(2, 1), .Cells(lrMain, 1)), _
.Cells(i + 1, 1).Value, .Range(.Cells(2, 27), .Cells(lrMain, 27)))
'If .Cells(i, 5) = "" Then
' .Cells(i, 35) = ""
'Else
' .Cells(i, 35).Value = Application.Index(indexVelocity1, _
' Application.Match(.Cells(i, 5), matchVelocity1, False))
'End If
' Thinking about it now, I am not sure about Application Index/Match on an array either.
If arrHolder(i, 5) = vbNullString Then
arrHolder(i, 35) = vbNullString
Else
arrHolder(i, 35) = Application.Index(indexVelocity1, _
Application.Match(arrHolder(i, 5), matchVelocity1, False))
End If
'If .Cells(i, 6).Value = 0 Then
' .Cells(i, 44).Value = 0
'Else
' .Cells(i, 44).Value = Round(((((.Cells(i, 6).Value / .Cells(i, 11).Value) _
' / .Cells(i, 10).Value) - .Cells(i, 8).Value) / .Cells(i, 35).Value), 0.1)
'End If
If arrHolder(i, 6) = 0 Then
arrHolder(i, 44) = 0
Else
arrHolder(i, 44) = Round(((((arrHolder(i, 6) / arrHolder(i, 11)) _
/ arrHolder(i, 10)) - arrHolder(i, 8)) / arrHolder(i, 35)), 0.1)
End If
'If .Cells(i, 6).Value = 0 Then
' .Cells(i, 34).Value = 0
' .Cells(i, 33) = 0
'Else
' .Cells(i, 34).Value = Round(((((.Cells(i, 6) / .Cells(i, 11)) / _
' .Cells(i, 10)) - .Cells(i, 8)) / .Cells(i, 35)) * .Cells(i, 11), 0.1)
' If .Cells(i, 34) > 0 Then
' .Cells(i, 33) = .Cells(i, 34)
' Else
' .Cells(i, 33) = 0
' End If
'End If
If arrHolder(i, 6) = 0 Then
arrHolder(i, 34) = 0
arrHolder(i, 33) = 0
Else
arrHolder(i, 34) = Round(((((arrHolder(i, 6) / arrHolder(i, 11)) / _
arrHolder(i, 10)) - arrHolder(i, 8)) / arrHolder(i, 35)) * arrHolder(i, 11), 0.1)
If arrHolder(i, 34) > 0 Then
arrHolder(i, 33) = arrHolder(i, 34)
Else
arrHolder(i, 33) = 0
End If
End If
'.Cells(i, 37) = 1 + calcWeek
arrHolder(i, 37) = 1 + calcWeek
'.Cells(i, 38) = .Cells(i, 5) & .Cells(i, 37)
arrHolder(i, 38) = arrHolder(i, 5) & arrHolder(i, 37)
'.Cells(i, 39).Value = Application.Index(indexVelocity2, _
' Application.Match(.Cells(i, 38), matchVelocity2, False))
arrHolder(i, 39) = Application.Index(indexVelocity2, _
Application.Match(arrHolder(i, 38), matchVelocity2, False))
'.Cells(i, 40) = Round(((((.Cells(i, 6) / .Cells(i, 11)) * .Cells(i, 39)) _
' - .Cells(i, 6)) - (.Cells(i, 8) - .Cells(i, 6))) / .Cells(i, 35), 0.1)
arrHolder(i, 40) = Round(((((arrHolder(i, 6) / arrHolder(i, 11)) * arrHolder(i, 39)) _
- arrHolder(i, 6)) - (arrHolder(i, 8) - arrHolder(i, 6))) / arrHolder(i, 35), 0.1)
'If .Cells(i, 40) < 0 Then
' .Cells(i, 41) = 0
'Else
' .Cells(i, 41) = .Cells(i, 40)
'End If
If arrHolder(i, 40) < 0 Then
arrHolder(i, 41) = 0
Else
arrHolder(i, 41) = arrHolder(i, 40)
End If
'.Cells(i, 42) = .Cells(i, 41) - .Cells(i, 33)
arrHolder(i, 42) = arrHolder(i, 41) - arrHolder(i, 33)
'If .Cells(i, 11) < .Cells(1, 44) Then
' .Cells(i, 45) = 0
' .Cells(i, 32) = .Cells(i, 45)
'Else
' .Cells(i, 32) = Application.Max(.Cells(i, 33), .Cells(i, 41))
' If .Cells(i, 44) < 0 Then
' .Cells(i, 45) = ""
' Else
' .Cells(i, 45) = .Cells(i, 44)
' End If
'End If
' Not 100% sure if applicaiton.max will work here.
If arrHolder(i, 11) < arrHolder(1, 44) Then
arrHolder(i, 45) = 0
arrHolder(i, 32) = arrHolder(i, 45)
Else
arrHolder(i, 32) = Application.Max(arrHolder(i, 33), arrHolder(i, 41))
If arrHolder(i, 44) < 0 Then
arrHolder(i, 45) = vbNullString
Else
arrHolder(i, 45) = arrHolder(i, 44)
End If
End If
'If .Cells(i, 31) < ShipMin Then
' .Cells(i, 47) = 0
'Else
' .Cells(i, 47) = .Cells(i, 27)
'End If
If arrHolder(i, 31) < ShipMin Then
arrHolder(i, 47) = 0
Else
arrHolder(i, 47) = arrHolder(i, 27)
End If
'.Cells(i, 46) = .Cells(i, 1) & .Cells(i, 22) & .Cells(i, 47)
arrHolder(i, 46) = arrHolder(i, 1) & arrHolder(i, 22) & arrHolder(i, 47)
End With
If (i Mod 100) = 0 Then
Debug.Print "Got to row "; i; " in "; Timer - MainTimer; " seconds."
End If
Next i
wsMain.Range(wsMain.Cells(2, 1), wsMain.Cells(lrMain, 47).Value = arrHolder
Erase arrHolder
End SubCode Review用户
发布于 2017-03-22 18:35:38
显然不工作的代码，可用作指南。
基本上，在处理数组时，您可以将数据从Worksheet.Range复制到VBA中基于内存的数组中。对该内存数组中的数据进行所有更改和计算。然后将完成的数组数据传输回工作表。
这里是一个非常快速和非常脏的转换，您的主循环使用数组。显然，我不能根据任何数据测试代码。数组的重要部分位于顶部：
Dim lastRow As Long
Dim lastCol As Long
lastRow = 500000 'make this a calculation
lastCol = 15 'make this a calculation or fixed
'--- capture the data to a memory array
Dim mainData As Variant
Dim mainDataArea As Range
Set mainDataArea = wsMain.Range("A1").Resize(lastRow, lastCol)
mainData = mainDataArea(您更了解如何确定lastRow和lastCol)
然后在运行循环之后，将其放回原处：
'--- copy the finished array back to the worksheet
mainDataArea = mainData我做了一个快速的全球搜索和替换，至少在你的主循环上有一个开始，让你去检查一下，作为你必须改变的东西的指南。
Const FIRSTNAME = 1 'column constants will make it far easier to debug
Const LASTNAME = 2
Const ADDRESS = 3
Const CITY = 4
Const STATE = 21
' . . .
Dim lastRow As Long
Dim lastCol As Long
lastRow = 500000 'make this a calculation
lastCol = 15 'make this a calculation or fixed
'--- capture the data to a memory array
Dim mainData As Variant
Dim mainDataArea As Range
Set mainDataArea = wsMain.Range("A1").Resize(lastRow, lastCol)
mainData = mainDataArea
For i = 2 To lrMain
Dim conUD As String 'con=concatenate
conUD = mainData(i, 21) & mainData(i, 4) & calcWeek
'---should be mainData(i, STATE) & mainData(i, CITY) & calcWeek
mainData(i, 21) = mainData(i, 5) & mainData(i, 3)
If mainData(i, 8) <> 0 Then
mainData(i, 9) = mainData(i, 6) / mainData(i, 8)
End If
Dim velocityRow As Long
If velocityLookup.Exists(conUD) Then
velocityRow = velocityLookup.Item(conUD)
tempLookup = wsVelocitymainData(velocityRow, 11)
End If
mainData(i, 10) = tempLookup
tempLookup = wsVelocitymainData(velocityRow, 14)
mainData(i, 11) = tempLookup
If mainData(i, 9) > mainData(i, 11) Then
mainData(i, 12) = Round((mainData(i, 6) / mainData(i, 11)) / mainData(i, 10), 0.1)
End If
If mainData(i, 6) > 0 Then
If mainData(i, 12) <> "" Then
mainData(i, 13) = mainData(i, 12) - mainData(i, 8)
End If
End If
Dim conECD As String
conECD = mainData(i, 5) & mainData(i, 3) & mainData(i, 4) & calcWeek
If velocityLookup.Exists(conECD) Then
velocityRow = velocityLookup.Item(conECD)
tempLookup = wsVelocitymainData(velocityRow, 12)
End If
If mainData(i, 13) <> "" Then
If tempLookup <> 0 Then
mainData(i, 14) = Int(mainData(i, 13) / tempLookup)
End If
End If
If velocityLookup.Exists(conECD) Then
velocityRow = velocityLookup.Item(conECD)
tempLookup = wsVelocitymainData(velocityRow, 13)
End If
If mainData(i, 14) > tempLookup Then
If mainData(i, 14) <> "" Then
mainData(i, 15) = tempLookup
End If
Else
mainData(i, 15) = mainData(i, 14)
End If
If mainData(i, 14) = "" Then
If mainData(i, 11) = "" Then
mainData(i, 26) = ""
Else
mainData(i, 26) = Round(mainData(i, 14) * mainData(i, 11), 0)
End If
End If
tempLookup = Application.Index(indexQuantity, Application.Match((mainData(i, 21) & "LIBERTY") _
, matchQuantity, False))
mainData(i, 24) = tempLookup
mainData(i, 18) = mainData(i, 24) - Application.SumIf(.Range(mainData(1, 21), mainData(i, 21)), _
mainData(i, 21), .Range(mainData(1, 26), mainData(i, 26)))
If velocityLookup.Exists(conUD) Then
velocityRow = velocityLookup.Item(conUD)
tempLookup = wsVelocitymainData(velocityRow, 13)
End If
If mainData(i, 26) > tempLookup Then
mainData(i, 28) = tempLookup
Else
mainData(i, 28) = mainData(i, 26)
End If
If mainData(i, 18) < 0 Then
mainData(i, 29) = "C"
mainData(i, 27) = ""
Else
mainData(i, 27) = mainData(i, 28)
End If
mainData(i, 31) = Application.SumIf(.Range(mainData(2, 1), mainData(lrMain, 1)), _
mainData(i, 1), .Range(mainData(2, 27), mainData(lrMain, 27)))
If mainData(i, 5) = "" Then
mainData(i, 35) = ""
Else
mainData(i, 35) = Application.Index(indexVelocity1, _
Application.Match(mainData(i, 5), matchVelocity1, False))
End If
If mainData(i, 6) = 0 Then
mainData(i, 44) = 0
Else
mainData(i, 44) = Round(((((mainData(i, 6) / mainData(i, 11)) _
/ mainData(i, 10)) - mainData(i, 8)) / mainData(i, 35)), 0.1)
End If
If mainData(i, 6) = 0 Then
mainData(i, 34) = 0
mainData(i, 33) = 0
Else
mainData(i, 34) = Round(((((mainData(i, 6) / mainData(i, 11)) / _
mainData(i, 10)) - mainData(i, 8)) / mainData(i, 35)) * mainData(i, 11), 0.1)
If mainData(i, 34) > 0 Then
mainData(i, 33) = mainData(i, 34)
Else
mainData(i, 33) = 0
End If
End If
mainData(i, 37) = 1 + calcWeek
mainData(i, 38) = mainData(i, 5) & mainData(i, 37)
mainData(i, 39) = Application.Index(indexVelocity2, _
Application.Match(mainData(i, 38), matchVelocity2, False))
mainData(i, 40) = Round(((((mainData(i, 6) / mainData(i, 11)) * mainData(i, 39)) _
- mainData(i, 6)) - (mainData(i, 8) - mainData(i, 6))) / mainData(i, 35), 0.1)
If mainData(i, 40) < 0 Then
mainData(i, 41) = 0
Else
mainData(i, 41) = mainData(i, 40)
End If
mainData(i, 42) = mainData(i, 41) - mainData(i, 33)
If mainData(i, 11) < mainData(1, 44) Then
mainData(i, 45) = 0
mainData(i, 32) = mainData(i, 45)
Else
mainData(i, 32) = Application.Max(mainData(i, 33), mainData(i, 41))
If mainData(i, 44) < 0 Then
mainData(i, 45) = ""
Else
mainData(i, 45) = mainData(i, 44)
End If
End If
If mainData(i, 31) < ShipMin Then
mainData(i, 47) = 0
Else
mainData(i, 47) = mainData(i, 27)
End If
mainData(i, 46) = mainData(i, 1) & mainData(i, 22) & mainData(i, 47)
If (i Mod 100) = 0 Then
Debug.Print "Got to row "; i; " in "; Timer - MainTimer; " seconds."
End If
Next i
'--- copy the finished array back to the worksheet
mainDataArea = mainDataCode Review用户
发布于 2017-03-25 15:05:45
最慢的部分通常是VBA和Excel之间的多次调用。实现这一目标的主要方法是一次将所有连续的数据放入数组中，并在完成后立即将其全部放回。但!Excel计算可以在在多个线程上并行中完成，并且只限于一个线程。这意味着在很大的范围内，使用Excel公式可能比VBA循环在数组上的速度更快。
例如：
For i = 2 To 5 'lrQuantity
With wsQuantity
.Cells(i, 5) = .Cells(i, 1) & .Cells(i, 2)
.Cells(i, 6) = .Cells(i, 1) & UCase(.Cells(i, 2).Value) & .Cells(i, 3)
End With
Next i可缩短为：
wsQuantity.Range("E2:E5") = wsQuantity.Evaluate("index(A2:A5 & B2:B5,)")
wsQuantity.Range("F2:F5") = wsQuantity.[index(A2:A5 & Upper(B2:B5) & C2:C5,)] ' [] is short for Evaluate("")或者：
With wsQuantity.Range("E2:F5")
.Formula = Array("= A2 & B2", "= A2 & Upper(B2) & C2") ' relative references (no $) are auto adjusted
.Value2 = .Value2 ' optional to convert the formulas to values
End With顺便提一句，我无法理解代码正在做什么，但在大多数情况下，VBA并不是聚合数据的最佳方法。Excel中还有一些比SQL查询简单一些的替代方法，比如Power查询、Microsoft，在某些情况下甚至还有PivotTable，它们可以将进程缩短到分钟。我强烈建议查看Power，如果Excel版本支持它，因为即使在将进程移动到数据库系统之后，也可以使用其中的大多数。
页面原文内容由Code Review提供。腾讯云小微IT领域专用引擎提供翻译支持
原文链接：
https://codereview.stackexchange.com/questions/158529
复制相关文章
相似问题
腾讯云开发者
Copyright © 2013 - 2026 Tencent Cloud. All Rights Reserved. 腾讯云 版权所有
深圳市腾讯计算机系统有限公司 ICP备案/许可证号：粤B2-20090059 
粤公网安备44030502008569号
腾讯云计算（北京）有限责任公司 京ICP证150476号 | 京ICP备11018762号