Выполнение кода VBA-Excel более эффективно

Question

Я запускаю этот код vba в Excel, он копирует столбцы из листа 1, вставляет его в лист два. Затем он сравнивает его с столбцом на листе 2 перед удалением любых дубликатов.

Private Sub CommandButton1_Click() 
Dim MasterList As New Dictionary 
    Dim iListCount As Integer 
    Dim x As Variant 
    Dim iCtr As Integer 
    Dim v As Variant 
    Dim counter As Integer, i As Integer 

    counter = 0 

    Sheets("Sheet2").Select 
    Sheets("Sheet2").Range("M:M").Select 
    Selection.ClearContents 

    Sheets("Sheet1").Select 
    Sheets("Sheet1").Range("C:C").Select 
    Selection.Copy 

    Sheets("Sheet2").Select 
    Sheets("Sheet2").Range("M1").Select 
    ActiveSheet.Paste 

    Application.ScreenUpdating = False 
    Application.Calculation = xlCalculationManual 

    ' Get count of records in master list 
    iListCount = Sheets("sheet2").Cells(Rows.Count, "A").End(xlUp).Row 

    'Load Dictionary: 
    For iCtr = 1 To iListCount 
     v = Sheets("sheet2").Cells(iCtr, "A").value 
     If Not MasterList.Exists(v) Then MasterList.Add v, "" 
    Next iCtr 

    'Get count of records in list to be deleted 
    iListCount = Sheets("sheet2").Cells(Rows.Count, "M").End(xlUp).Row 


    'Loop through the "delete" list. 
    For iCtr = iListCount To 1 Step -1 
     If MasterList.Exists(Sheets("Sheet2").Cells(iCtr, "M").value) Then 
      Sheets("Sheet2").Cells(iCtr, "M").Delete shift:=xlUp 
     End If 
    Next iCtr 


    Application.ScreenUpdating = True 
    Application.Calculation = xlCalculationAutomatic 

    MsgBox "Done!" 

End Sub 

Существует только под 30000 строк, что он должен сравнить, так что я знаю, что она всегда собирается занять некоторое время, но мне было интересно, есть ли какой-либо способ ускорить его или даже просто сделать свой код более оптимизированы и эффективны.

Answer 1

не копировать и вставлять из листа 1 к листу 2. Сохраните значения из двух листов в массивах:

Dim v1 as variant, v2 as variant 

v1 = Sheet1.Range("C:C").Value 
v2 = Sheet2.Range("A1").Resize(iListCount,1).Value 

Затем прочитайте значения в v1 в словаре, пропустите значения в v2 и проверьте, существует ли каждый из них в словаре или нет. Если они существуют, удалите элемент из словаря.

Answer 2

Это позволит сделать его немного более эффективным

Dim MasterList As New Dictionary 
Dim iListCount As Integer 
Dim x As Variant 
Dim iCtr As Integer 
Dim v As Variant 
Dim counter As Integer, i As Integer 
counter = 0 

Application.ScreenUpdating = False 
Application.Calculation = xlCalculationManual 

With Sheets("Sheet2") 
    .Range("M:M").ClearContents 

    Sheets("Sheet1").Range("C:C").Copy 
    .Range("M1").Paste 

    ' Get count of records in master list 
    iListCount = .Cells(Rows.Count, "A").End(xlUp).Row 
    'Load Dictionary: 
    For iCtr = 1 To iListCount 
     v = .Cells(iCtr, "A").Value 
     If Not MasterList.Exists(v) Then MasterList.Add v, "" 
    Next iCtr 

    'Get count of records in list to be deleted 
    iListCount = .Cells(Rows.Count, "M").End(xlUp).Row 

    ' Loop through the "delete" list. 
    For iCtr = iListCount To 1 Step -1 
     If MasterList.Exists(.Cells(iCtr, "M").Value) Then 
      .Cells(iCtr, "M").Delete shift:=xlUp 
     End If 
    Next iCtr 

End With 

Application.ScreenUpdating = True 
Application.Calculation = xlCalculationAutomatic 

MsgBox "Done!" 

Если вы действительно хотите, чтобы сделать его более effceint я изменил бы ниже

' Loop through the "delete" list. 
    For iCtr = iListCount To 1 Step -1 
     If MasterList.Exists(.Cells(iCtr, "M").Value) Then 
      .Cells(iCtr, "M").Delete shift:=xlUp 
     End If 
    Next iCtr 

Так что вы пропустите лист. например удалите их из словаря, а затем очистите список, а затем выведите словарь в одной строке кода. Доступ к листу - дорогостоящая часть с точки зрения использования ЦП, ограничивает, сколько раз вы получаете доступ к листу для гораздо более быстрого кода. Вы могли бы также попытаться снять петлю для чтения записей в и попытаться сделать это в одной строке кода слишком

Медленные части рассмотреть

.Cells(iCtr, "A").Value 

и, вероятно, в результате чего большую часть времени ниже

.Cells(iCtr, "M").Delete shift:=xlUp 

Answer 3

Вот моя версия оптимизированного кода.

Комментарии о используемых концепциях помещаются в код.

Private Sub CommandButton1_Click() 
    Dim MasterList As New Dictionary 
    Dim data As Variant 
    Dim dataSize As Long 
    Dim lastRow As Long 
    Dim row As Long 
    Dim value As Variant 
    Dim comparisonData As Variant 
    Dim finalResult() As Variant 
    Dim itemsAdded As Long 
    '----------------------------------------------------------------- 


    'First load data from column C of [Sheet1] into array (processing 
    'data from array is much more faster than processing data 
    'directly from worksheets). 
    'Also, there is no point to paste the data to column M of Sheet2 right now 
    'and then remove some of them. We will first remove unnecessary items 
    'and then paste the final set of data into column M of [Sheet2]. 
    'It will reduce time because we can skip deleting rows and this operation 
    'was the most time consuming in your original code. 
    With Sheets("Sheet1") 
     lastRow = .Range("C" & .Rows.Count).End(xlUp).row 
     data = .Range("C1:C" & lastRow) 
    End With 


    'We can leave this but we don't gain much with it right now, 
    'since all the operations will be calculated in VBA memory. 
    Application.ScreenUpdating = False 
    Application.Calculation = xlCalculationManual 



    'We make the same operation to load data from column A of Sheet2 
    'into another array - [comparisonData]. 
    'It can seem as wasting time - first load into array instead 
    'of directly iterating through data, but in fact it will allow us 
    'to save a lot of time - since iterating through array is much more 
    'faster than through Excel range. 
    With Sheets("Sheet2") 
     lastRow = .Range("A" & .Rows.Count).End(xlUp).row 
     comparisonData = .Range("A1:A" & lastRow) 
    End With 

    'Iterate through all the items in array [comparisonData] and load them 
    'into dictionary. 
    For row = LBound(comparisonData, 1) To UBound(comparisonData, 1) 
     value = comparisonData(row, 1) 

     If Not MasterList.Exists(value) Then 
      Call MasterList.Add(value, "") 
     End If 

    Next row 


    'Change the size of [finalResult] array to make the place for all items 
    'assuming no data will be removed. It will save some time because we 
    'won't need to redim array with each iteration. 
    'Some items of this array will remain empty, but it doesn't matter 
    'since we only want to paste it into worksheet. 
    'We create 2-dimensional array to avoid transposing later and save 
    'even some more time. 
    dataSize = UBound(data, 1) - LBound(data, 1) 
    ReDim finalResult(1 To dataSize, 1 To 1) 


    'Now iterate through all the items in array [data] and compare them 
    'to dictionary [MasterList]. All the items that are found in 
    '[MasterDict] are added to finalResult array. 
    For row = LBound(data, 1) To UBound(data, 1) 
     value = data(row, 1) 

     If MasterList.Exists(value) Then 
      itemsAdded = itemsAdded + 1 
      finalResult(itemsAdded, 1) = value 
     End If 

    Next row 



    'Now the finalResult array is ready and we can print it into worksheet: 
    Dim rng As Range 
    With Sheets("Sheet2") 
     Call .Range("M:M").ClearContents 
     .Range("M1").Resize(dataSize, 1) = finalResult 
    End With 


    'Restore previous settings. 
    Application.ScreenUpdating = True 
    Application.Calculation = xlCalculationAutomatic 


    MsgBox "Done!" 


End Sub