使VBA-Excel代碼更高效

Question

我在Excel中運行此vba代碼，它從工作表1復制一列，並將其粘貼到工作表2中。 然后將其與工作表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

它必須比較的行數不到30,000，所以我知道它總是要花一些時間，但是我想知道是否有任何方法可以加快它的速度，甚至只是使我的代碼更加簡化和高效。

Answer 1

這將使其更有效率

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

如果您真的想提高效率，我將在下面進行更改

    ' 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

讓您錯過工作表。 例如，將它們從字典中刪除，然后清除列表，然后以一行代碼輸出字典。 訪問表是CPU使用方面最昂貴的部分，請限制訪問表的次數以獲得更快的代碼。 您也可以嘗試刪除用於讀取條目的循環，並嘗試在一行代碼中進行操作

需要考慮的零件較慢

.Cells(iCtr, "A").Value

並可能導致以下大部分時間

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

Answer 2

不要從工作表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 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