Rendre le code VBA-Excel plus efficace

Ne copyz pas et ne collez pas de la feuille 1 à la fiche 2. Enregistrez les valeurs des deux feuilles dans les arrays:

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

Ensuite, lisez les valeurs dans v1 dans un dictionary, faites une boucle dans les valeurs dans v2 et vérifiez si chacune d'entre elles existe ou non dans le dictionary. Si elles existent, retirez l'object du dictionary.

Cela rendra un peu plus efficace

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

Si vous vouliez vraiment faire plus effacer, je modifierais ci-dessous

  ' 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 

De sorte que vous manquez la feuille. Par exemple, supprimez-les du dictionary, puis effacez la list, puis lancez le dictionary dans une seule ligne de code. L'access à la feuille est la partie coûteuse en termes d'utilisation du processeur, limitez combien de fois vous accédez à la feuille pour un code beaucoup plus rapide. Vous pouvez également essayer de supprimer la boucle pour lire les inputs et essayer de le faire dans une seule ligne de code aussi

Des pièces lentes à considérer

 .Cells(iCtr, "A").Value 

et probablement causant la plupart du time ci-dessous

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

Voici ma version du code optimisé.

Les commentaires sur les concepts utilisés sont mis dans le code.

 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