使VBA-Excel代码更高效

Question

I am running this vba code in Excel, it copies a columns from sheet 1, pastes it into sheet two. It then compares it to a column in sheet two before deleting any duplicates.

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

There is just under 30,000 rows that it has to compare so I know that it is always going to take some time, but I was wondering if there was any way to speed it up or even just make my code more streamline and efficient.

Answer 1

This will make it a bit more efficient

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

If you really wanted to make it more effceint I would change below

    ' 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

So that you miss the sheet. eg delete them out of the dictionary and then clear the list and then output the dictionary in one line of code. Accessing the sheet is the costly part in terms of CPU use, limit how many times you access the sheet for much much faster code. you could also try to remove the loop for reading entries in and try and do that in one line of code too

Slow parts to consider

.Cells(iCtr, "A").Value

and probably causing most of the time below

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

Answer 2

Don't copy and paste from sheet 1 to sheet 2. Store the values from both sheets in arrays:

Dim v1 as variant, v2 as variant

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

Then read the values in v1 into a dictionary, loop through the values in v2 and check if each of them exists in the dictionary or not. If they exist, remove the item from the dictionary.

Answer 3

Here is my version of optimized code.

Comments about the concepts used are put in the 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