Как ускорить проверку и копирование в ListObject

Question

Я работал с проектом, в котором книга аварийно завершает работу, если добавлено слишком много строк данных (в данном случае их слишком много, например 3000). Несмотря на то, что я обновил рабочую книгу до теперь не только sh, она по-прежнему работает очень медленно - для добавления 900 строк с 5 столбцами требуется около 33 секунд. Конечная таблица, вероятно, будет иметь около 35 столбцов (из которых около 15 будут формулами) и более 5000 строк, поэтому я уже обеспокоен. Коллеги также хотели иметь возможность обновления с использованием «несоответствующих» таблиц: importTable может иметь столбцы A, B, C, E и master будет иметь A, C, E, F и фактически необходимые столбцы ( в adminTable) являются A, C, E. У кого-нибудь есть идеи? Эта подпрограмма уже включена в другую подпрограмму, которая отключает screenUpdating, DisplayAlerts и Calculation. Я предполагаю, что икота в строке .Copy ...

Sub detectChanges(adminTbl As ListObject, importTbl As ListObject, masterTbl As ListObject)

  Dim i                           As Long
  Dim j                           As Long
  Dim elements As Long
  Dim Header As Variant
  Dim foundHeader As Variant
  Dim cHead As String
  Dim ID As Variant
  Dim foundID As Range

  elements = 0

  'loops through the set admin headers. This format will not copy non-similar data, nor overwrite custom columns that have been added to the data
 'NOTE: Below assumed that unique identifier is ALWAYS in first column.
  For i = 1 To masterTbl.ListRows.Count
    'grabs ID
    ID = masterTbl.ListColumns(1).DataBodyRange(i)
    'tests for a ID match
    Set foundID = importTbl.ListColumns(1).Range.Find(IC, LookAt:=xlWhole)

    If Not foundID Is Nothing Then
        'only checks for changes in admin columns, skipping the ID column
        For j = 2 To adminTbl.ListColumns.Count
            cHead = adminTbl.ListColumns(j).Name
            If masterTbl.ListColumns(cHead).DataBodyRange(i) <> 
            importTbl.ListColumns(cHead).DataBodyRange(foundID.Row - importTbl.HeaderRowRange.Row) Then
            'This line changes the color of the changed element

                    importTbl.ListColumns(cHead).DataBodyRange(foundID.Row - importTbl.HeaderRowRange.Row).Copy masterTbl.ListColumns(cHead).DataBodyRange(i)
                    masterTbl.ListColumns(cHead).DataBodyRange(i).Interior.Color = RGB(255, 235, 156)
                              'keeping track of elements
                    elements = elements + 1
            End If
        Next j

    End If

Next i

  'Say elements changed
 'MsgBox "Total elements changed in update: " & elements

End Sub

Answer 1

Я предполагаю, что вы совпадаете с идентификаторами в таблице импорта с тем же идентификатором в основной таблице. Вы можете использовать объект словаря для хранения номеров строк, соответствующих каждому идентификатору в основной таблице. Постройте словарь, отсканировав основную таблицу один раз. Затем просканируйте таблицу импорта и используйте словарь, чтобы найти соответствующую строку в основной таблице, не ища ее. Например

     Sub test()
       Dim wb As Workbook, ws As Worksheet
       Set wb = ThisWorkbook
       Set ws = wb.Sheets(1)

       '  tables
       Dim importTbl As ListObject, masterTbl As ListObject, adminTbl As ListObject
       Set importTbl = ws.ListObjects(1)
       Set masterTbl = ws.ListObjects(2)
       Set adminTbl = ws.ListObjects(3)

       Call detectChanges(adminTbl, importTbl, masterTbl)
     End Sub


     Sub detectChanges(adminTbl As ListObject, importTbl As ListObject, masterTbl As ListObject)

       ' build dictionary from master table
       Dim dictMaster
       Set dictMaster = CreateObject("Scripting.Dictionary")

       Dim masterRow As ListRow, ID As String
       For Each masterRow In masterTbl.ListRows
         ID = masterRow.Range.Cells(1, 1)
         dictMaster.Add ID, masterRow.index
       Next masterRow

       ' check import table against master table
       Dim importRow As ListRow, col As ListColumn
       Dim index As Long, chgCount As Long
       Dim cellMaster, cellImport As Range

       For Each importRow In importTbl.ListRows
         ID = importRow.Range.Cells(1, 1)
         If dictMaster.exists(ID) Then
           ' found - checks for changes in admin columns
           index = dictMaster(ID)
           For Each col In adminTbl.ListColumns

             cHead = col.Name
             Set cellMaster = masterTbl.ListColumns(cHead).DataBodyRange.Rows(index)
             Set cellImport = importTbl.ListColumns(cHead).DataBodyRange.Rows(importRow.index)
             'Debug.Print cHead, cellMaster.Address, cellImport.Address

             If cellMaster.Value <> cellImport.Value Then
                cellImport.Copy cellMaster
                cellMaster.Interior.Color = RGB(255, 235, 156)

               'keeping track of elements
               chgCount = chgCount + 1
             End If
           Next col
         Else
           ' not found - do nothing
         End If
       Next importRow

       MsgBox "Total elements changed in update: " & chgCount

     End Sub

Answer 2

Одним из способов повышения производительности является уменьшение взаимодействия VBA с объектами Excel, поэтому вполне понятно, что циклы могут сильно повлиять на производительность.

Давайте посмотрим на ваши три цикла.

L oop 1

For i = 1 To masterTbl.ListRows.Count

Это основной l oop в вашем алгоритме, и он, вероятно, проходит по неверной таблице. Если обе таблицы имеют одинаковый размер, это не имеет значения; однако, если мастер больше, чем импорт (как это часто бывает), то вы без необходимости зацикливаетесь на строках в мастере, которые не могут существовать при импорте.

L oop 2

importTbl.ListColumns(1).Range.Find(IC, LookAt:=xlWhole)

Многие люди упускают из виду простой факт, что Find - это всего лишь oop, и он особенно неэффективен, когда вложен в For l oop. Рассмотрим For l oop, который перебирает таблицу с 500 строками: Find будет вызываться 500 раз, а первая строка - 500 раз. Если все 500 строк содержат совпадение, то Find потребуется только 125 125 оценок, чтобы найти все 500. Теперь держитесь за свое место, если есть только одно совпадение, и оно находится в 500-м ряду, Find сделает 249,499 оценок, прежде чем найти его на 249,500-й. А если нет совпадений? Все 500 строк будут оценены 500 раз, ошеломляющие 250 000 оценок! Давайте не будем забывать, что это все оценки на рабочем листе, то, что вы хотите минимизировать.

L oop 3

For j = 2 To adminTbl.ListColumns.Count

Это самый внутренний l oop и тот, кто отвечает за выполнение реальной работы. Здесь есть несколько проблем, которые я расскажу отдельно.

• Если HeaderRowRange не изменится во время выполнения, тогда вы можете избежать повторных ссылок на importTbl.HeaderRowRange.Row и ускорить процесс (хотя и незаметно), присваивая номер строки переменной над вашими циклами. Затем вы будете использовать эту переменную везде, где вам это нужно.

• Работа по ячейкам также замедляет работу. Вы должны читать по одной ячейке за раз, но вам не нужно читать каждую ячейку. Нахождения одного изменения достаточно, чтобы обновить залог строки таблицы из l oop с помощью Exit For.

---

Это много раздумий, которые включают много переписанного кода , но это не то, что я на самом деле делаю. Я бы взял go для низко висящих фруктов, используя фильтр, который уменьшает размер внешнего l oop и устраняет Find.

. Нам нужен массив для фильтра. Это очень быстрое короткое l oop отлично работает:

Dim aryID() as String
ReDim aryID(1 to masterTbl.ListRows.Count)
For i = 1 To UBound(aryID)
    'grabs ID
    aryID(I) = masterTbl.ListColumns(1).DataBodyRange(i).Value2
Next i

Нам нужно назначить фильтр, и мы можем сделать это с одним вкладышем, фильтры могут быть хитрыми, потому что текущий фильтр может быть активным, неактивным, или отсутствует. Поэтому я обычно передаю таблицу в подпрограмму, чтобы сбросить фильтр в известное состояние, прежде чем установить критерии:

ResetTableFilters masterTbl
masterTbl.Range.AutoFilter Field:=1, Criteria1:=arryID Operator:=xlFilterValues

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

---

Sub ResetTableFilters(lo As ListObject)
    If lo.ShowAutoFilter Then lo.DataBodyRange.AutoFilter
    lo.DataBodyRange.AutoFilter                 
End Sub




Sub detectChanges(adminTbl As ListObject, importTbl As ListObject, masterTbl As ListObject)

Dim i As Long
Dim j As Long
Dim elements As Long
Dim Header As Variant
Dim foundHeader As Variant
Dim cHead As String
Dim ID As Variant
Dim foundID As Range

 elements = 0

 'loops through the set admin headers. This format will not copy non-similar data, nor overwrite custom columns that have been added to the data
 'NOTE: Below assumed that unique identifier is ALWAYS in first column.

Dim aryID() as String
ReDim aryID(1 to masterTbl.ListRows.Count)
For i = 1 To UBound(aryID)
    'grabs ID
    aryID(I) = masterTbl.ListColumns(1).DataBodyRange(i).Value2
Next i


For i = 1 To masterTbl.ListColumns(1).DataBodyRange(i).SpecialCells(xlCellTypeVisible).Count

    'checks for changes in admin columns, skipping the ID column
    For j = 2 To adminTbl.ListColumns.Count
        cHead = adminTbl.ListColumns(j).Name
        If masterTbl.ListColumns(cHead).DataBodyRange(i) <> 
        importTbl.ListColumns(cHead).DataBodyRange(foundID.Row - importTbl.HeaderRowRange.Row) Then
        'This line changes the color of the changed element


          importTbl.ListColumns(cHead).DataBodyRange(foundID.Row -   importTbl.HeaderRowRange.Row).Copy    masterTbl.ListColumns(cHead).DataBodyRange(i)

              masterTbl.ListColumns(cHead).DataBodyRange(i).Interior.Color = RGB(255, 235, 156)
                          'keeping track of elements
                elements = elements + 1
        End If
    Next j

End If

Next i

'Say elements changed
MsgBox "Total elements changed in update: " & elements

End Sub