使VBA-Excel代码更高效

Question

我在Excel中运行此vba代码，它从工作表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

有不到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