Проблемы с производительностью Excel VBA при работе в таблице (listobject)

Question

Я ищу несколько советов по улучшению производительности моего кода VBA или надеюсь, что кто-то поймет, в чем заключается моя проблема, поскольку я сам не могу понять.

Что должен делать код:

• Существует лист конфигурации, где пользователь может установить ограничения по времени.Эти временные ограничения будут использоваться для создания сегментов (например, «от 15 до 30 минут»)
• Эти сегменты будут вставлены рядом со столбцом значений в именованной таблице (в столбце есть простые числа -целые и двойные числа - для времени работы)

Код работает.Он делает то, что я хочу, но это очень медленно.Добавление ведер примерно для 100 предметов занимает ~ 22 секунды.На 2000 предметов это уже 7 минут.Однако могут быть сценарии, в которых мне нужно было бы поставить корзины рядом со 128 000 записей.Однако я знаю, что это можно решить с помощью простых формул, но таблица данных уже огромна (2000 строк и 400 столбцов) с большим количеством вычисляемых столбцов.

Я читал, что в более новых версиях Excel возникают проблемы с производительностью, когданеобходимо получить доступ к ячейкам в таблицах, но нигде не удалось найти правильное решение.Ценю любые советы и хитрости.

То, что я уже пробовал (но ничего не улучшило результаты значительно):

• Попробовал много разных типов данных в разных комбинациях
• Изменил If ... ElseifВыбрать Case
• Попытка создать сегменты на листе, чтобы 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

Answer 1

Благодаря @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

Answer 2

Увеличивает ли ваш цикл for размер таблицы объектов в каждой итерации?Это реальная скорость, если это то, что происходит.Я не смог точно определить, что происходит, но, похоже, он переопределяет Application.Calculate и вызывает пересчет.

Вы упомянули, что не хотите делать это с формулами.Вы пытаетесь найти подход?Я полагаю, что это также свалило бы.Вы также можете явно получить сегменты, предполагая, что A2 - это дата / время продолжительности с секундами:

="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"