Excel VBA 在 table (listobject) 中工作时的性能问题
Excel VBA performance issues when working in table (listobject)
我正在寻找一些技巧来提高我的 vba 代码的性能，或者希望有人能发现我的问题所在，因为我自己也搞不清楚。
代码应该做什么：
- 有一个配置 sheet，用户可以在其中设置时间限制。这些时间限制将用于创建存储桶（例如 "between 15 and 30 minutes"）
- 然后这些桶将被插入到命名的 table 中的一列值旁边（在该列中有简单的数字 - 整数和双精度数 - 用于行驶时间）
代码有效。它做我想做的，但速度非常慢。添加大约 100 个项目的桶需要大约 22 秒。在 2000 件物品上，它已经 7 分钟了。但是，在某些情况下，我需要将存储桶放在 128 000 个条目旁边。但是我知道这可以用简单的公式来解决，但是数据 table 已经很大（2000 行和 400 列）并且有很多计算列。
我了解到 excel 的较新版本在需要访问 table 中的单元格时存在性能问题，但无法在任何地方找到合适的解决方案。感谢任何提示和技巧。
我已经尝试过的事情（但没有显着改善结果）：
- 在许多不同的组合中尝试了许多不同的数据类型
- 将 If...Elseif 更改为 Select 大小写
- 尝试在 sheet 上创建存储桶，因此 VBA 不需要将其连接到字符串变量中
请参阅下面我的代码片段，如果您想了解任何其他信息，请告诉我。
Sub Buckets()
Application.Calculation = xlCalculationManual
Application.DisplayStatusBar = False
Application.EnableEvents = False
ActiveSheet.DisplayPageBreaks = False
Application.ScreenUpdating = False
Dim ws As Worksheet
Dim conf As Worksheet
Dim rcount As Long
Dim bucket1 As String
Dim bucket2 As String
Dim bucket3 As String
Dim bucket4 As String
Dim bucket5 As String
Dim bucket6 As String
Dim bucket7 As String
Dim bucket8 As String
Dim lim As Integer
Dim lim1 As Integer
Dim lim2 As Integer
Dim lim3 As Integer
Dim lim4 As Integer
Dim lim5 As Integer
Dim lim6 As Integer
Dim number As Double
Dim ScenNo As Integer
Dim Datarange As Range
Dim Bucketrange As Range
Dim i As Integer
Set conf = Worksheets("Config")
Set ws = Worksheets("DATABASE")
Set Datarange = ws.Range("A9:A2008")
Set Bucketrange = ws.Range("B9:B2008")
rcount = ws.ListObjects("TABLE").ListColumns(7).Range.Find("*", searchorder:=xlByRows, LookIn:=xlValues, searchdirection:=xlPrevious).Row
'B54 to B60 contains numbers from 15 up to 90 with a step of 15 minutes. The top value is 1000
With conf
bucket1 = "Below " & .Range("B54").Value2 & " minutes"
bucket2 = "Between " & .Range("B54").Value2 & " and " & .Range("B55").Value2 & " minutes"
bucket3 = "Between " & .Range("B55").Value2 & " and " & .Range("B56").Value2 & " minutes"
bucket4 = "Between " & .Range("B56").Value2 & " and " & .Range("B57").Value2 & " minutes"
bucket5 = "Between " & .Range("B57").Value2 & " and " & .Range("B58").Value2 & " minutes"
bucket6 = "Between " & .Range("B58").Value2 & " and " & .Range("B59").Value2 & " minutes"
bucket7 = "Between " & .Range("B59").Value2 & " and " & .Range("B60").Value2 & " minutes"
bucket8 = "Above " & .Range("B60").Value2 & " minutes"
lim = .Range("B54").Value2
lim1 = .Range("B55").Value2
lim2 = .Range("B56").Value2
lim3 = .Range("B57").Value2
lim4 = .Range("B58").Value2
lim5 = .Range("B59").Value2
lim6 = .Range("B60").Value2
End With
For i = 9 To rcount
If Cells(i, 16) = "" Or Cells(i, 16) = "Exclude" Then 'y - 1
GoTo SKIPSTEP
End If
number = Datarange(i - 8, 1).Value2 'y - 1
If number < lim Then
Bucketrange(i - 8, 1) = Buckets(1, 1).Value2
ElseIf number >= lim And number < lim1 Then
Bucketrange(i - 8, 1) = Buckets(2, 1).Value2
ElseIf number >= lim1 And number < lim2 Then
Bucketrange(i - 8, 1) = Buckets(3, 1).Value2
ElseIf number >= lim2 And number < lim3 Then
Bucketrange(i - 8, 1) = Buckets(4, 1).Value2
ElseIf number >= lim3 And number < lim4 Then
Bucketrange(i - 8, 1) = Buckets(5, 1).Value2
ElseIf number >= lim4 And number < lim5 Then
Bucketrange(i - 8, 1) = Buckets(6, 1).Value2
ElseIf number >= lim5 And number < lim6 Then
Bucketrange(i - 8, 1) = Buckets(7, 1).Value2
Else
Bucketrange(i - 8, 1) = Buckets(8, 1).Value2
End If
SKIPSTEP:
Next i
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.DisplayStatusBar = True
Application.EnableEvents = True
ActiveSheet.DisplayPageBreaks = True
End Sub
您的 for 循环是否会在每次迭代时增加列表对象 table 的大小？如果这就是正在发生的事情，那将是一个真正的减速带。我无法确定发生了什么，但它似乎覆盖了 Application.Calculate 并强制重新计算。
你提到不想用公式来做这件事。你在尝试查找方法吗？我想这也会陷入困境。您还可以显式地导出存储桶，假设 A2 是持续时间 date/time，秒数：
="between "
&(A2-DATE(YEAR(A2),MONTH(A2),DAY(A2)))*24*60-MOD((A2-DATE(YEAR(A2),MONTH(A2),DAY(A2)))*24*60,15)
&" and "
&(A2-DATE(YEAR(A2),MONTH(A2),DAY(A2)))*24*60-MOD((A2-DATE(YEAR(A2),MONTH(A2),DAY(A2)))*24*60,15)+15
&" minutes"
感谢@Rory，我将数字加载到一个数组中，现在它运行时间为 1.2 秒而不是 7 分钟。请参阅下面的代码片段的简化版本。我知道这可能会有一些额外的改进。一旦我可以稍微整理一下代码，我就会编辑我的答案。万分感谢@Rory，希望这对其他人也有帮助。
Sub Buckets()
Dim starttime As Double
Dim finish As Double
Dim endtime As Double
starttime = Timer()
Application.Calculation = xlCalculationManual
Application.DisplayStatusBar = False
Application.EnableEvents = False
ActiveSheet.DisplayPageBreaks = False
Application.ScreenUpdating = False
Dim ws As Worksheet
Dim conf As Worksheet
Dim rcount As Long
Dim bucket1 As String
Dim bucket2 As String
Dim bucket3 As String
Dim bucket4 As String
Dim bucket5 As String
Dim bucket6 As String
Dim bucket7 As String
Dim bucket8 As String
Dim lim As Integer
Dim lim1 As Integer
Dim lim2 As Integer
Dim lim3 As Integer
Dim lim4 As Integer
Dim lim5 As Integer
Dim lim6 As Integer
Dim number As Double
Dim ScenNo As Integer
Dim x As Integer
Dim y As Integer
Dim Datarange() As Double
Dim Bucketrange() As String
Dim cell As Range
Set conf = Worksheets("Config")
With conf
bucket1 = "Below " & .Range("B54").Value2 & " minutes"
bucket2 = "Between " & .Range("B54").Value2 & " and " & .Range("B55").Value2 & " minutes"
bucket3 = "Between " & .Range("B55").Value2 & " and " & .Range("B56").Value2 & " minutes"
bucket4 = "Between " & .Range("B56").Value2 & " and " & .Range("B57").Value2 & " minutes"
bucket5 = "Between " & .Range("B57").Value2 & " and " & .Range("B58").Value2 & " minutes"
bucket6 = "Between " & .Range("B58").Value2 & " and " & .Range("B59").Value2 & " minutes"
bucket7 = "Between " & .Range("B59").Value2 & " and " & .Range("B60").Value2 & " minutes"
bucket8 = "Above " & .Range("B60").Value2 & " minutes"
lim = .Range("B54").Value2
lim1 = .Range("B55").Value2
lim2 = .Range("B56").Value2
lim3 = .Range("B57").Value2
lim4 = .Range("B58").Value2
lim5 = .Range("B59").Value2
lim6 = .Range("B60").Value2
End With
Set ws = Worksheets("DATABASE")
x = 0
For Each cell In ws.Range("R9:R2008")
ReDim Preserve Datarange(x)
Datarange(x) = cell.Value2
x = x + 1
Next cell
x = 0
Dim i As Variant
y = 0
For Each i In Datarange
If i < lim Then
ReDim Preserve Bucketrange(y)
Bucketrange(y) = bucket1
y = y + 1
ElseIf i >= lim And i < lim1 Then
ReDim Preserve Bucketrange(y)
Bucketrange(y) = bucket2
y = y + 1
ElseIf i >= lim1 And i < lim2 Then
ReDim Preserve Bucketrange(y)
Bucketrange(y) = bucket3
y = y + 1
ElseIf i >= lim2 And i < lim3 Then
ReDim Preserve Bucketrange(y)
Bucketrange(y) = bucket4
y = y + 1
ElseIf i >= lim3 And i < lim4 Then
ReDim Preserve Bucketrange(y)
Bucketrange(y) = bucket5
y = y + 1
ElseIf i >= lim4 And i < lim5 Then
ReDim Preserve Bucketrange(y)
Bucketrange(y) = bucket6
y = y + 1
ElseIf i >= lim5 And i < lim6 Then
ReDim Preserve Bucketrange(y)
Bucketrange(y) = bucket7
y = y + 1
Else
ReDim Preserve Bucketrange(y)
Bucketrange(y) = bucket8
y = y + 1
End If
Next i
ws.Range("S9:S2008") = Application.Transpose(Bucketrange)
Erase Datarange
Erase Bucketrange
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.DisplayStatusBar = True
Application.EnableEvents = True
ActiveSheet.DisplayPageBreaks = True
End Sub
我正在寻找一些技巧来提高我的 vba 代码的性能，或者希望有人能发现我的问题所在，因为我自己也搞不清楚。
代码应该做什么：
- 有一个配置 sheet，用户可以在其中设置时间限制。这些时间限制将用于创建存储桶（例如 "between 15 and 30 minutes"）
- 然后这些桶将被插入到命名的 table 中的一列值旁边（在该列中有简单的数字 - 整数和双精度数 - 用于行驶时间）
代码有效。它做我想做的，但速度非常慢。添加大约 100 个项目的桶需要大约 22 秒。在 2000 件物品上，它已经 7 分钟了。但是，在某些情况下，我需要将存储桶放在 128 000 个条目旁边。但是我知道这可以用简单的公式来解决，但是数据 table 已经很大（2000 行和 400 列）并且有很多计算列。
我了解到 excel 的较新版本在需要访问 table 中的单元格时存在性能问题，但无法在任何地方找到合适的解决方案。感谢任何提示和技巧。
我已经尝试过的事情（但没有显着改善结果）：
- 在许多不同的组合中尝试了许多不同的数据类型
- 将 If...Elseif 更改为 Select 大小写
- 尝试在 sheet 上创建存储桶，因此 VBA 不需要将其连接到字符串变量中
请参阅下面我的代码片段，如果您想了解任何其他信息，请告诉我。
Sub Buckets()
Application.Calculation = xlCalculationManual
Application.DisplayStatusBar = False
Application.EnableEvents = False
ActiveSheet.DisplayPageBreaks = False
Application.ScreenUpdating = False
Dim ws As Worksheet
Dim conf As Worksheet
Dim rcount As Long
Dim bucket1 As String
Dim bucket2 As String
Dim bucket3 As String
Dim bucket4 As String
Dim bucket5 As String
Dim bucket6 As String
Dim bucket7 As String
Dim bucket8 As String
Dim lim As Integer
Dim lim1 As Integer
Dim lim2 As Integer
Dim lim3 As Integer
Dim lim4 As Integer
Dim lim5 As Integer
Dim lim6 As Integer
Dim number As Double
Dim ScenNo As Integer
Dim Datarange As Range
Dim Bucketrange As Range
Dim i As Integer
Set conf = Worksheets("Config")
Set ws = Worksheets("DATABASE")
Set Datarange = ws.Range("A9:A2008")
Set Bucketrange = ws.Range("B9:B2008")
rcount = ws.ListObjects("TABLE").ListColumns(7).Range.Find("*", searchorder:=xlByRows, LookIn:=xlValues, searchdirection:=xlPrevious).Row
'B54 to B60 contains numbers from 15 up to 90 with a step of 15 minutes. The top value is 1000
With conf
bucket1 = "Below " & .Range("B54").Value2 & " minutes"
bucket2 = "Between " & .Range("B54").Value2 & " and " & .Range("B55").Value2 & " minutes"
bucket3 = "Between " & .Range("B55").Value2 & " and " & .Range("B56").Value2 & " minutes"
bucket4 = "Between " & .Range("B56").Value2 & " and " & .Range("B57").Value2 & " minutes"
bucket5 = "Between " & .Range("B57").Value2 & " and " & .Range("B58").Value2 & " minutes"
bucket6 = "Between " & .Range("B58").Value2 & " and " & .Range("B59").Value2 & " minutes"
bucket7 = "Between " & .Range("B59").Value2 & " and " & .Range("B60").Value2 & " minutes"
bucket8 = "Above " & .Range("B60").Value2 & " minutes"
lim = .Range("B54").Value2
lim1 = .Range("B55").Value2
lim2 = .Range("B56").Value2
lim3 = .Range("B57").Value2
lim4 = .Range("B58").Value2
lim5 = .Range("B59").Value2
lim6 = .Range("B60").Value2
End With
For i = 9 To rcount
If Cells(i, 16) = "" Or Cells(i, 16) = "Exclude" Then 'y - 1
GoTo SKIPSTEP
End If
number = Datarange(i - 8, 1).Value2 'y - 1
If number < lim Then
Bucketrange(i - 8, 1) = Buckets(1, 1).Value2
ElseIf number >= lim And number < lim1 Then
Bucketrange(i - 8, 1) = Buckets(2, 1).Value2
ElseIf number >= lim1 And number < lim2 Then
Bucketrange(i - 8, 1) = Buckets(3, 1).Value2
ElseIf number >= lim2 And number < lim3 Then
Bucketrange(i - 8, 1) = Buckets(4, 1).Value2
ElseIf number >= lim3 And number < lim4 Then
Bucketrange(i - 8, 1) = Buckets(5, 1).Value2
ElseIf number >= lim4 And number < lim5 Then
Bucketrange(i - 8, 1) = Buckets(6, 1).Value2
ElseIf number >= lim5 And number < lim6 Then
Bucketrange(i - 8, 1) = Buckets(7, 1).Value2
Else
Bucketrange(i - 8, 1) = Buckets(8, 1).Value2
End If
SKIPSTEP:
Next i
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.DisplayStatusBar = True
Application.EnableEvents = True
ActiveSheet.DisplayPageBreaks = True
End Sub
您的 for 循环是否会在每次迭代时增加列表对象 table 的大小？如果这就是正在发生的事情，那将是一个真正的减速带。我无法确定发生了什么，但它似乎覆盖了 Application.Calculate 并强制重新计算。
你提到不想用公式来做这件事。你在尝试查找方法吗？我想这也会陷入困境。您还可以显式地导出存储桶，假设 A2 是持续时间 date/time，秒数：
="between "
&(A2-DATE(YEAR(A2),MONTH(A2),DAY(A2)))*24*60-MOD((A2-DATE(YEAR(A2),MONTH(A2),DAY(A2)))*24*60,15)
&" and "
&(A2-DATE(YEAR(A2),MONTH(A2),DAY(A2)))*24*60-MOD((A2-DATE(YEAR(A2),MONTH(A2),DAY(A2)))*24*60,15)+15
&" minutes"
感谢@Rory，我将数字加载到一个数组中，现在它运行时间为 1.2 秒而不是 7 分钟。请参阅下面的代码片段的简化版本。我知道这可能会有一些额外的改进。一旦我可以稍微整理一下代码，我就会编辑我的答案。万分感谢@Rory，希望这对其他人也有帮助。
Sub Buckets()
Dim starttime As Double
Dim finish As Double
Dim endtime As Double
starttime = Timer()
Application.Calculation = xlCalculationManual
Application.DisplayStatusBar = False
Application.EnableEvents = False
ActiveSheet.DisplayPageBreaks = False
Application.ScreenUpdating = False
Dim ws As Worksheet
Dim conf As Worksheet
Dim rcount As Long
Dim bucket1 As String
Dim bucket2 As String
Dim bucket3 As String
Dim bucket4 As String
Dim bucket5 As String
Dim bucket6 As String
Dim bucket7 As String
Dim bucket8 As String
Dim lim As Integer
Dim lim1 As Integer
Dim lim2 As Integer
Dim lim3 As Integer
Dim lim4 As Integer
Dim lim5 As Integer
Dim lim6 As Integer
Dim number As Double
Dim ScenNo As Integer
Dim x As Integer
Dim y As Integer
Dim Datarange() As Double
Dim Bucketrange() As String
Dim cell As Range
Set conf = Worksheets("Config")
With conf
bucket1 = "Below " & .Range("B54").Value2 & " minutes"
bucket2 = "Between " & .Range("B54").Value2 & " and " & .Range("B55").Value2 & " minutes"
bucket3 = "Between " & .Range("B55").Value2 & " and " & .Range("B56").Value2 & " minutes"
bucket4 = "Between " & .Range("B56").Value2 & " and " & .Range("B57").Value2 & " minutes"
bucket5 = "Between " & .Range("B57").Value2 & " and " & .Range("B58").Value2 & " minutes"
bucket6 = "Between " & .Range("B58").Value2 & " and " & .Range("B59").Value2 & " minutes"
bucket7 = "Between " & .Range("B59").Value2 & " and " & .Range("B60").Value2 & " minutes"
bucket8 = "Above " & .Range("B60").Value2 & " minutes"
lim = .Range("B54").Value2
lim1 = .Range("B55").Value2
lim2 = .Range("B56").Value2
lim3 = .Range("B57").Value2
lim4 = .Range("B58").Value2
lim5 = .Range("B59").Value2
lim6 = .Range("B60").Value2
End With
Set ws = Worksheets("DATABASE")
x = 0
For Each cell In ws.Range("R9:R2008")
ReDim Preserve Datarange(x)
Datarange(x) = cell.Value2
x = x + 1
Next cell
x = 0
Dim i As Variant
y = 0
For Each i In Datarange
If i < lim Then
ReDim Preserve Bucketrange(y)
Bucketrange(y) = bucket1
y = y + 1
ElseIf i >= lim And i < lim1 Then
ReDim Preserve Bucketrange(y)
Bucketrange(y) = bucket2
y = y + 1
ElseIf i >= lim1 And i < lim2 Then
ReDim Preserve Bucketrange(y)
Bucketrange(y) = bucket3
y = y + 1
ElseIf i >= lim2 And i < lim3 Then
ReDim Preserve Bucketrange(y)
Bucketrange(y) = bucket4
y = y + 1
ElseIf i >= lim3 And i < lim4 Then
ReDim Preserve Bucketrange(y)
Bucketrange(y) = bucket5
y = y + 1
ElseIf i >= lim4 And i < lim5 Then
ReDim Preserve Bucketrange(y)
Bucketrange(y) = bucket6
y = y + 1
ElseIf i >= lim5 And i < lim6 Then
ReDim Preserve Bucketrange(y)
Bucketrange(y) = bucket7
y = y + 1
Else
ReDim Preserve Bucketrange(y)
Bucketrange(y) = bucket8
y = y + 1
End If
Next i
ws.Range("S9:S2008") = Application.Transpose(Bucketrange)
Erase Datarange
Erase Bucketrange
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.DisplayStatusBar = True
Application.EnableEvents = True
ActiveSheet.DisplayPageBreaks = True
End Sub