Обработка VBA для Excel все медленнее и медленнее, чем дольше она работает


У меня есть код, созданный и нужна ваша поддержка, чтобы оптимизировать его. VBA для анализа электронных таблиц для 6 даты расположены в Столбцах (вехи) и определяет последнюю дату, имя столбца и состояние, если есть какие-либо статуса для столбца дата. В результате на VBA вставляет эти данные в дополнительных колонках, расположенных в одном листе, так и называется:

  • Текущий Этап
  • Дата
  • Статус

Проблема, когда я запускаю этот код VBA для таблицы с небольшим количеством строк он работает хорошо, но больше количество линий медленнее он работает. Я подсчитал, что 7400 линии (50 мин. работать с VBA) производить результат с 10 раз меньше строк/мин Скорость по сравнению с 460 линий (20 сек для запуска VBA) и разница становится больше вместе с количеством строк в таблице.

Перед VBA-это я всегда хватать VBA, чтобы отключить автоматический расчет EXP.EnableCalculation = False в качестве примера на этот лист. Мне повторить для всех таблиц в моей книге. На данный момент Всемирный банк имеет 77 таблиц. Некоторые из них имеют исходные данные и некоторые из них содержат формулы сводные таблицы со ссылкой на первичные данные. Общий размер файла составляет более 25 Мб. Формат файла *.Файл xlsb

Ниже приведен пример кода, который я использую.

Ценю вашу помощь заранее!

Sub D_13_Exp_LAM()

Application.ScreenUpdating = False

Sheets("Exp").Activate
ActiveWindow.FreezePanes = False
Range("A:PA").EntireColumn.Hidden = False

Dim today As Date
today = Date

'============= Exp =====================
T = 52
Do While Worksheets("Exp").Cells(1, T).Value <> ""
Select Case Worksheets("Exp").Cells(1, T)
Case "MS 11.6 Site Integration Completed [AC]"
Case "MS 11.8 Site On-Air [AC]"
Case "MS 11.9.1 Technical part of PAC ready [AC]"
Case "MS 11.9.2 Technical part of PAC approved [AC]"
Case "MS 11.10 PAC Issued [AC]"
Case "MS 13.1 FAC Issued [AC]"

Case Else
     Worksheets("Exp").Columns(T).Hidden = True
End Select
T = T + 1
Loop

 i = 2
 Do While Worksheets("Exp").Cells(i, 1).Value <> ""


 'When SITEID & Phase & Scope create unique character line
 SITEID = Worksheets("Exp").Cells(i, 1)
 Phase = Worksheets("Exp").Cells(i, 2)
 Scope = Worksheets("Exp").Cells(i, 3)
 Unique_Key = SITEID & "_" & Phase & "_" & Scope


 'When SITEID & Phase & Scope does not match, put No_Information
 Worksheets("Exp").Cells(i, 5) = "No_Info"

 'Initialize TowerCo type
 Worksheets("Exp").Cells(i, 6) = ""

 'Move Scope sheet
 j = 2
 Region_Column = Worksheets(Scope).Cells.Find(What:="QROI RO Zone").Column

 Phase_Column = 2

 Do While Worksheets(Scope).Cells(j, 1).Value <> ""
   SITEID_name = Worksheets(Scope).Cells(j, 1)
   Phase_name = Worksheets(Scope).Cells(j, Phase_Column)
   Unique_Key_name = SITEID_name & "_" & Phase_name & "_" & Scope

   'If there is target site on Scope sheet
   If Unique_Key = Unique_Key_name Then

        'Input Onair Actual on Summary
        Worksheets("Exp").Cells(i, Worksheets("Exp").Cells.Find(What:="QROI RO Zone").Column) = Worksheets(Scope).Cells(j, Region_Column)

    r = 6

    Select Case Scope
    Case "Exp"


'MS 13.1 FAC Issued [AC]
        If Worksheets(Scope).Cells(j, Worksheets(Scope).Cells.Find(What:="MS 13.1 FAC Issued [AC]").Column) <> "" Then
            Worksheets("Exp").Cells(i, r) = "MS 13.1 FAC Issued [AC]"
            Worksheets("Exp").Cells(i, r + 1) = Worksheets(Scope).Cells(j, Worksheets(Scope).Cells.Find(What:="MS 13.1 FAC Issued [AC]").Column)
'MS 11.10 PAC Issued [AC]
        ElseIf Worksheets(Scope).Cells(j, Worksheets(Scope).Cells.Find(What:="MS 11.10 PAC Issued [AC]").Column) <> "" Then
            Worksheets("Exp").Cells(i, r) = "MS 11.10 PAC Issued [AC]"
            Worksheets("Exp").Cells(i, r + 1) = Worksheets(Scope).Cells(j, Worksheets(Scope).Cells.Find(What:="MS 11.10 PAC Issued [AC]").Column)
'MS 11.9.2 Technical part of PAC approved [AC]
        ElseIf Worksheets(Scope).Cells(j, Worksheets(Scope).Cells.Find(What:="MS 11.9.2 Technical part of PAC approved [AC]").Column) <> "" Then
            Worksheets("Exp").Cells(i, r) = "MS 11.9.2 Technical part of PAC approved [AC]"
            Worksheets("Exp").Cells(i, r + 1) = Worksheets(Scope).Cells(j, Worksheets(Scope).Cells.Find(What:="MS 11.9.2 Technical part of PAC approved [AC]").Column)
'MS 11.9.1 Technical part of PAC ready [AC]
        ElseIf Worksheets(Scope).Cells(j, Worksheets(Scope).Cells.Find(What:="MS 11.9.1 Technical part of PAC ready [AC]").Column) <> "" Then
            Worksheets("Exp").Cells(i, r) = "MS 11.9.1 Technical part of PAC ready [AC]"
            Worksheets("Exp").Cells(i, r + 1) = Worksheets(Scope).Cells(j, Worksheets(Scope).Cells.Find(What:="MS 11.9.1 Technical part of PAC ready [AC]").Column)
'MS 11.8 Site On-Air [AC]
        ElseIf Worksheets(Scope).Cells(j, Worksheets(Scope).Cells.Find(What:="MS 11.8 Site On-Air [AC]").Column) <> "" Then
            Worksheets("Exp").Cells(i, r) = "MS 11.8 Site On-Air [AC]"
            Worksheets("Exp").Cells(i, r + 1) = Worksheets(Scope).Cells(j, Worksheets(Scope).Cells.Find(What:="MS 11.8 Site On-Air [AC]").Column)
'MS 11.6 Site Integration Completed [AC]
        ElseIf Worksheets(Scope).Cells(j, Worksheets(Scope).Cells.Find(What:="MS 11.6 Site Integration Completed [AC]").Column) <> "" Then
            Worksheets("Exp").Cells(i, r) = "MS 11.6 Site Integration Completed [AC]"
            Worksheets("Exp").Cells(i, r + 1) = Worksheets(Scope).Cells(j, Worksheets(Scope).Cells.Find(What:="MS 11.6 Site Integration Completed [AC]").Column)

         End If

    End Select

    '====Past Days calucuration on Current Milestone====
    'Current Status
    latest_status = Worksheets("Exp").Cells(i, r)

        'No Progress
        If latest_status = "" Then
            Worksheets("Exp").Cells(i, r + 1) = "-"

        'Onair
        ElseIf latest_status = "MS 13.1 FAC Issued Actual" Then
            Worksheets("Exp").Cells(i, r + 3) = "Cong!!!"

        'Approve & reject case
        ElseIf Worksheets("Exp").Cells(i, r + 2) = "N/A" Then
            Worksheets("Exp").Cells(i, r + 3) = "N/A"

        ElseIf Worksheets("Exp").Cells(i, r + 2) > 0 Then
            Worksheets("Exp").Cells(i, r + 3) = today - Worksheets("Exp").Cells(i, r + 1)

        End If

    Exit Do

    End If
j = j + 1
Loop

i = i + 1

Loop

''''Re-appear on hidden cell


Sheets("Exp").Activate
Range("A:PA").EntireColumn.Hidden = False

ActiveSheet.Range("E2").Select
ActiveWindow.FreezePanes = False
ActiveWindow.FreezePanes = True

Application.ScreenUpdating = True

End Sub


720
4
задан 11 апреля 2018 в 05:04 Источник Поделиться
Комментарии
2 ответа

В идеале вы должны работать непосредственно с данными, а не с помощью накладных листов и ячеек.

Я бы предложил делать это с помощью инструкции SQL непосредственно в отношении данных, поскольку это позволяет декларативно, касающиеся данных, а не использовать циклы, а также позволяет ссылаться на имена столбцов вместо числовых индексов. (Используя массив в качестве Raystafarian предполагает также улучшение.)


Пока вы не в состоянии сделать радикальные изменения в код, я бы сразу предложить следующие способы их быстрого устранения.


  1. Для каждой строки, чтобы найти в каком столбце содержится дата определенная веха, вы ищете всю таблицу для текстовых значений. Этот поиск повторяется между 4 и 12 раз для каждой строки каждой таблицы. (NB это не имеет смысла поиск по всей таблице значений вы знаете, будет только в первой строке.)

    Рассмотрим кэширование этой информации. Если она не меняется от листа к листу, вы можете кэшировать его вне цикла крайними; в противном случае вы должны сделать это внутри внешнего цикла.

    Я хотел бы предложить, используя Scripting Dictionary для этой цели. Добавление пары ключ (имя Milestone) и значение индекса (столбец) в словаре, а затем вы можете передать ключ, чтобы вернуть соответствующее значение. Добавить ссылку (инструменты -> ссылки...) в среда выполнения сценариев Microsoft библиотека. Тогда можно написать следующий код:

    'This only needs to be done once for the entire macro; it should go outside of the outermost loop
    Dim milestoneNames As Variant
    ' on multiple lines, so it is easier to read
    milestoneNames = Array( _
    "MS 13.1 FAC Issued [AC]", _
    "MS 11.10 PAC Issued [AC]", _
    "MS 11.9.2 Technical part of PAC approved [AC]", _
    "MS 11.9.1 Technical part of PAC ready [AC]", _
    "MS 11.8 Site On-Air [AC]", _
    "MS 11.6 Site Integration Completed [AC]")

    'If the following could be different between worksheets, it should be within the outermost loop
    Dim milestoneColumns as New Scripting.Dictionary
    Dim firstRow As Range
    Set firstRow = Worksheets(Scope).Rows(1)
    Dim milestoneName As Variant
    For Each milestoneName In milestoneNames
    milestoneColumns(milestoneName) = firstRow.Find(What:=milestoneName).Column
    Next

    Затем, мы можем заменить вызовы .Find с призывами к Dictionary, например, следующие:

    If Worksheets(Scope).Cells(j, Worksheets(Scope).Cells.Find(What:="MS 13.1 FAC Issued [AC]").Column) <> "" Then

    можно заменить:

    If Worksheets(Scope).Cells(j, milestoneColumns("MS 13.1 FAC Issued [AC]")) <> "" Then

  2. Код используется только один известный листе за один раз. Если это так, то вы можете заменить каждую ссылку либо Worksheets("Exp") или Worksheets(Scope) встроенная переменная, которая ссылается на таблицу-возможно, EXP или Exp.

    Если это не так, то вы должны хранить лист, соответствующий текущей области в переменной:

    Scope = Worksheets("Exp").Cells(i, 3)
    Dim wksScope As Worksheet
    Set wksScope = Worksheets(Scope)

    и заменить каждое использование Worksheets(Scope) с переменной. Например:

    Phase_name = Worksheets(Scope).Cells(j, Phase_Column)

    станет:

    Phase_name = wksScope.Cells(j, Phase_Column)

  3. Как только вы определили вехи имена в массив, вы можете консолидировать все If заявления в один For Each петли:

    For Each milestoneName In milestoneNames
    Dim cellValue As Variant
    cellValue = wksScope.Cells(j, milestoneColumns(milestoneName)).Value
    If cellValue <> "" Then
    wksExp.Cells(i, r) = milestoneName
    wksExp.Cells(i, r + 1) = cellValue
    Exit For
    End If
    Next

3
ответ дан 11 апреля 2018 в 02:04 Источник Поделиться

Вы не можете видеть это в ваш код, но у вас вложенные тонны материала -

Do While Worksheets("Exp").Cells(i, 1).Value <> ""
Do While Worksheets(Scope).Cells(j, 1).Value <> ""
If Unique_Key = Unique_Key_name Then
Select Case Scope
Case "Exp"
'MS 13.1 FAC Issued [AC]
If Worksheets(Scope).Cells(j, Worksheets(Scope).Cells.Find(what:="MS 13.1 FAC Issued [AC]").Column) <> "" Then
ElseIf Worksheets(Scope).Cells(j, Worksheets(Scope).Cells.Find(what:="MS 11.10 PAC Issued [AC]").Column) <> "" Then
ElseIf Worksheets(Scope).Cells(j, Worksheets(Scope).Cells.Find(what:="MS 11.9.2 Technical part of PAC approved [AC]").Column) <> "" Then
ElseIf Worksheets(Scope).Cells(j, Worksheets(Scope).Cells.Find(what:="MS 11.9.1 Technical part of PAC ready [AC]").Column) <> "" Then
ElseIf Worksheets(Scope).Cells(j, Worksheets(Scope).Cells.Find(what:="MS 11.8 Site On-Air [AC]").Column) <> "" Then
ElseIf Worksheets(Scope).Cells(j, Worksheets(Scope).Cells.Find(what:="MS 11.6 Site Integration Completed [AC]").Column) <> "" Then
End If
End Select

If latest_status = "" Then
ElseIf latest_status = "MS 13.1 FAC Issued Actual" Then
ElseIf Worksheets("Exp").Cells(i, r + 2) = "N/A" Then
ElseIf Worksheets("Exp").Cells(i, r + 2) > 0 Then
End If

Exit Do
End If
j = j + 1
Loop
i = i + 1
Loop

Это вызывает проблемы сам по себе. Но если учесть также тот факт, что ты делаешь все на лист-

Sheets("Exp").Activate
Range("A:PA").EntireColumn.Hidden = False
Sheets("Exp").Activate
ActiveWindow.FreezePanes = False
Range("A:PA").EntireColumn.Hidden = False
ActiveSheet.Range("E2").Select
ActiveWindow.FreezePanes = False
ActiveWindow.FreezePanes = True

Я не удивлен, что это занимает несколько часов. И .FIND это один из самых медленных процедур, которые можно использовать. И вы используете его много. Быть определенным, когда вы можете.

Я не знаю, почему у вас есть SELECT CASE. Я не уверен, почему вы не можете комбинировать условия. Те вещи, которые нужно сделать с вашими данными. Что я могу сказать, что вам нужны массивы.

Массивы

Делать на листе медленно. Он просто замедляет код по необходимости возиться с электронными таблицами, а делать все остальное за кадром. Есть хороший вопрос на StackOverflow решение этой.

Просто приведите свои данные, сделать свое дело и потом выплюнула -

Application.ScreenUpdating = False
Dim lastRow As Long
lastRow = Worksheets("Exp").Cells(Rows.Count, 1).End(xlUp).Row
Dim lastColumn As Long
lastColumn = 6 'or whatever
Dim dataArray As Variant
dataArray = Worksheets("Exp").Range(Worksheets("Exp").Cells(1, 1), Worksheets("Exp").Cells(lastRow, lastColumn))
For i = 1 To lastRow
uniqueKey = dataArray(i, 1) & "_" & datarray(i, 2) & "_" & dataArray(i, 3)
If dataArray(i, j) = "QROI RO Zone" Then
datarray(i, x) = dataArray(i, y) 'etc
'make changes in array
End If
Next
Worksheets("Exp").Range(Worksheets("Exp").Cells(1, 1), Worksheets("Exp").Cells(lastRow, lastColumn)) = dataArray
Columns(8).Hidden = True
'other things
Application.ScreenUpdating = True

Очевидно, этот код не просто работать, но это дает вам представление о том, как переделать ваш макрос. Это трудно для меня, чтобы переписать его без структуры данных очевидны.

Я готов поспорить, что одно только это изменение принесет ваш время обработки до 1 минуты.

Также, как в сторону - VBA имеет постоянного vbNullString что можно использовать вместо "".

5
ответ дан 11 апреля 2018 в 05:04 Источник Поделиться