需要更好的优化代码？

Question

需要一个非常优化的代码。好吧，我有一个项目，我已经成功地使它与 vba 一起工作（主要是由 stackoverflow 程序员提供的，谢谢） 但是今天我收到了反馈。它在记录中删除了另外 2 个唯一条目但我不知道为什么要删除它们。

我应用的算法

我已经使用了我在 google 上找到的 COUNTIF 函数

    ="countif(A$1:A2,A3)=0" A3 is the active cell, Checks A2,A1 for dupes

如果 A 列中存在重复则抛出 False，如果它是唯一的则抛出 True。我对 Countif 的理解是 它检查该单元格中的所有上述列值，我的意思是让我们取 A4。所以它检查 A2,A1,A3 是否有重复项。同样，A10 检查 A1 到 A9 并抛出 TRue 或 False。它工作正常，但我不知道出了什么问题代码不适用于某些条目。有时甚至会为唯一条目显示 False。

由于我拥有更多数据，因此应用这些公式需要更多时间。我试图让它更清洁和更优化的方式。人们告诉我它不是 c 或其他语言来优化它，但我需要让我的代码更优化的代码

我需要这些条件的代码，任何人都可以帮助我，因为我的计数失败了。我这样做有点无助。

1）我有一列，我应该检查该列中的重复项，如果重复则删除该行

2) 我在该列中有 35000 个旧条目，并且我每周都有 2000 个新条目，这些都被附加。我需要从总共 37000 个条目中检查这 2000 个条目（当我们追加时，我们得到 35000+2000 个），并且这些删除操作只需要对新添加的 2000 个条目执行，但它应该检查整个列的重复项

让我清楚地解释一下，我新添加了 2000 个条目，因此仅检查这些条目是否与 35000 个条目以及其自身（2000 个条目）中的重复项，如果是重复项且没有重复操作则将其删除应该对 35000 个条目的旧数据执行。

我找到了一些代码，但它们甚至删除了 35000 个条目的重复项。我已经设置了范围，但即使它不起作用。 任何人都可以帮助我编写花费更少时间的最佳代码吗？谢谢

用我的示例代码更新我的问题

   A       B            F       G        H       I              Y          
  PTY   39868.5         4       2       540      3      PTY39868.5425403 
  GTY   34446.1234      2       1       230      1      GTY34446.1234212301
  PTY   3945.678                2                2       PTY3945.67822
  GTY   34446.1234      2       1       230      1      GTY34446.1234212301
                  let us say these are old 35000 entries

上面例子的解释。

以上是35000个条目。我必须检查 A、B、F、G、H、I 列是否有欺骗性，如果它们相同，我必须删除该行，我不应该为其他列 c、d 等而烦恼，所以我所做的是我使用了一个未使用的 Y 列，并使用这些将这 6 个列的值连接到 Y 列的 1

  = A2 & B2 & F2 & G2 & H2 &I2 with the respective columns

现在检查 Y 列是否存在欺骗并删除整行。据我所知，2003 年仅支持一栏。

请注意，即使是 35000 个条目也可能有重复项，但我不应该删除它们。示例您可以看到我的示例代码中的第 2 行和最后一行是骗子，但我不应该删除 因为它是旧数据。

   A       B            F       G        H       I              Y          
  PTY   39868.5         4       2       540      3      PTY39868.5425403     'old 
  GTY   34446.1234      2       1       230      1      GTY34446.1234212301   'old
  PTY   3945.678                2                2       PTY3945.67822        'old
  GTY   34446.1234      2       1       230      1      GTY34446.1234212301    'old
  PTY    3945.678       1       1       230      2      PTY3945.678112302      'new
  PTY    39868.5        4       2       540      3      PTY39868.5425403       'new 
  PTY    3945.678       1       1       230      2      PTY3945.678112302      'new

现在请注意，新条目 PTY（从最后 2 个开始）是原始记录的副本（最初是 PTY）所以我必须删除它。最后一个新条目是新条目本身的副本，所以我应该删除它甚至那个。所以在上面的代码中，我只需要删除最后 2 行，它们是原始记录的副本，也可以从中删除。但不应该删除被骗但在原始记录中的GTY。

我想我现在给出了一个清晰的观点。将它们连接成一个单元格。是更好的方法吗？作为 40000 个条目的 conactenatin 仅需 2 秒，我认为这没关系，但任何更多算法对这些都非常有用

我听说 counif 将 45.00 和 45.00000 视为不同的，是正确的可能是它的问题吗？因为我的数据中有小数点。我觉得我应该这样做

    = I2 & H2 & G2 & F2 & A2 & B2

哪个更好连接？这是我之前发布的还是其他的？

Answer 1

重大更新：

它认为最初的问题让我失望 - 问题中的逻辑可能存在问题。以下假设您要删除重复条目的单元格，而不是整行。

• 如果 35000 条旧记录不包含重复项，那么您需要做的就是从整个列中删除所有重复项 - 只要您从第 1 行开始，就不会冒删除任何“旧”行的风险因为其中不存在重复项。

这是一种方法：

Sub UniqueList()

Application.ScreenUpdating = False
Dim vArray As Variant
Dim i As Long, j As Long, lastrow As Long
Dim dictionary As Object
Set dictionary = CreateObject("scripting.dictionary")

lastrow = Range("A" & Rows.Count).End(xlUp).Row
vArray = Range("A1:A" & lastrow).Value

On Error Resume Next
For i = 1 To UBound(vArray, 1)
    For j = 1 To UBound(vArray, 2)
        If Len(vArray(i, j)) <> 0 Then
            dictionary(vArray(i, j)) = 1
        End If
    Next
Next

Columns("A:A").ClearContents
Range("A1").Resize(dictionary.Count).Value = _
Application.Transpose(dictionary.keys)

Application.ScreenUpdating = True

End Sub

• 如果出于某种奇怪的原因，35000 条旧记录确实包含欺骗，而您只想允许这 35000 条记录这样做，那么您可以使用 2 个字典，但这将是一种不寻常的情况，因为您将处理旧的记录与新记录不同...

Sub RemoveNewDupes()

Application.ScreenUpdating = False
Dim lastRow As Long
Dim varray As Variant
Dim oldDict As Object, newDict As Object
Set oldDict = CreateObject("scripting.dictionary")
Set newDict = CreateObject("scripting.dictionary")

On Error Resume Next
lastRow = Range("A" & Rows.Count).End(xlUp).Row

'Add old entries to dictionary
varray = Range("A1:A35000").Value
For i = 1 To UBound(varray, 1)
    oldDict.Add varray(i, 1), 1
Next

'Check for dupes
varray = Range("A35001:A" & lastRow).Value
For i = 1 To UBound(varray, 1)
    If oldDict.exists(varray(i, 1)) = False Then
        newDict.Add varray(i, 1), 1
    End If
Next

'Delete and slap back on the unique list
Range("A35001", "A" & Rows.Count).ClearContents
Range("A35001").Resize(newDict.Count).Value = _
Application.Transpose(newDict.keys)

Application.ScreenUpdating = True
End Sub

感谢 Reafidy 的建议，让我重新审视这个。

Answer 2

这也是对其他成员提出的一些cmet和解决方案的回应，如果没有立即回答您的问题，请见谅。

首先，我认为在数据库场景中使用 excel 应该将原始数据和演示数据分开。这通常意味着包含原始数据的单个工作表和包含演示数据的多个其他工作表。然后在必要时删除原始数据或存档。

在进行速度测试时，很难在 excel 中获得一个公平的竞争环境，因为影响结果的因素很多。计算机规格、可用 RAM 等。在运行任何程序之前，必须首先编译代码。在考虑重复时，测试数据也很重要 - 有多少重复与多少行。这个子加载一些测试数据，改变行数和随机数（重复）的范围会给你的代码带来非常不同的结果。我不知道你的数据是什么样的，所以我们有点盲目地工作，你的结果可能会有很大的不同。

'// This is still not very good test data, but should suffice for this situation.
Sub TestFill()
    '// 300000 rows
    For i = 1 To 300000
        '// This populates a random number between 1 & 10000 - adjust to suit
        Cells(i, "A").value = Int((100000 + 1) * Rnd + 1)
    Next
End Sub

如果我们谈论的是高级过滤器与数组和字典方法，那么高级过滤器在行数较少的情况下会更快，但是一旦超过一定数量的行，数组方法会更快。然后看看当你改变重复的数量时会发生什么...... :) 作为准则或一般规则，使用内置函数的 excel 会更快，我建议始终尝试使用这些内置函数进行开发，但是通常有例外，例如在删除重复项时。 :)

如果使用不当，在循环时删除行可能会很慢。如果使用循环，那么保持代码和工作簿之间的同步在循环之外很重要。这通常意味着将数据读取到数组中，循环遍历数据，然后将数组中的数据加载回演示工作表，从而删除不需要的数据。

Sub RemoveDuplicatesA()

    '// Copy raw data to presentation sheet
    Range("A1", Cells(Rows.Count, "A").End(xlUp)).AdvancedFilter _
        Action:=xlFilterCopy, CopyToRange:=Sheet2.Range("B1"), Unique:=True

End Sub

这将是最快的方法：

Sub RemoveDuplicatesB()        
    Dim vData As Variant, vArray As Variant
    Dim lCnt As Long, lRow As Long

    vData = ActiveSheet.UsedRange.Columns(1).value
    ReDim vArray(0 To UBound(vData, 1), 0)
    lCnt = 0

    With CreateObject("Scripting.Dictionary")
        For lRow = 1 To UBound(vData, 1)
            If Not .Exists(vData(lRow, 1)) Then
                vArray(lCnt, 0) = vData(lRow, 1): lCnt = lCnt + 1
                .Add vData(lRow, 1), Nothing
            End If
        Next lRow
    End With

    '// Copy raw data to presentation sheet
    Sheet2.Range("B1").Resize(lCnt).value = vArray

End Sub

应用程序转置有 65536 行的限制，但由于您使用的是 2003，所以使用它应该没问题，因此您可以使用以下代码简化上述代码：

Sub RemoveDuplicatesC()
    Dim vData As Variant
    Dim lRow As Long

    vData = ActiveSheet.UsedRange.Columns(1).value

    With CreateObject("Scripting.Dictionary")
        For lRow = 1 To UBound(vData, 1)
            If Not .exists(vData(lRow, 1)) Then
                .Add vData(lRow, 1), Nothing
            End If
        Next lRow

        '// Copy raw data to presentation sheet or replace raw data
        Sheet2.Columns(2).ClearContents
        Sheet2.Columns(2).Resize(.Count).value = Application.Transpose(.keys)
    End With

End Sub 

编辑

好的，@Issun 提到您希望删除整行。我的建议是通过拥有原始数据和演示文稿表来改进您的电子表格布局，这意味着您不需要删除任何内容，因此这将是最快的方法。如果您不想这样做并想直接编辑原始数据，请尝试以下操作：

 Sub RemoveDuplicatesD()
    Dim vData As Variant, vArray As Variant
    Dim lRow As Long       

    vData = ActiveSheet.UsedRange.Columns(1).value
    ReDim vArray(1 To UBound(vData, 1), 0)     

    With CreateObject("Scripting.Dictionary")
        For lRow = 1 To UBound(vData, 1)
            If Not .exists(vData(lRow, 1)) Then
                varray(lRow, 0) = "x"
                .Add vData(lRow, 1), Nothing
            End If
        Next lRow
    End With

    Application.ScreenUpdating = False

    '// Modify the raw data
    With ActiveSheet
        .Columns(2).Insert
        .Range("B1").Resize(lRow).value = vArray
        .Columns(2).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
        .Columns(2).Delete
    End With

    Application.ScreenUpdating = True
End Sub

Answer 3

在从头开始编写整个代码之前，您可以尝试以下几点：

优化您的 VBA 网上有几个关于优化 vba 的提示。特别是，您可以这样做：

'turn off some Excel functionality so your code runs faster
'these two are especially very efficient
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
'use these if you really need to
Application.DisplayStatusBar = False
Application.EnableEvents = False

'code goes here

'at the end, restore the default behavior
'calculate the formulas
Application.Calculate
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.DisplayStatusBar = True
Application.EnableEvents = True

更多信息请参见here

优化您的算法 特别是当您插入COUNTIF 公式时，您可以尝试填写而不是在每一行中插入公式。

在删除行部分，您应该尝试我在上一个帖子中给您的解决方案：Delete duplicate entries in a column in excel 2003 vba 首先过滤 True 值，然后删除可见单元格。这可能是最快的方式。

[EDIT] 似乎 Doc Brown 的回答可能是处理此问题的最佳方法（嘿，这是一个不是 Issun 编写的字典解决方案 :)）。无论如何，VBA 优化技巧仍然是相关的，因为这是一种非常缓慢的语言。

Answer 4

好的，这里是高级过滤方法。不知道是不是比字典方法快。不过知道会很有趣，所以在你尝试后告诉我。我还包括了删除部分，因此如果您想进行真正的比较，则必须停止该部分。此外，您可以将其设为函数而不是子函数并放入变量中，但您想更改它。

Sub DeleteRepeats()

    Dim d1 As Double
    Dim r1 As Range, rKeepers As Range
    Dim wks As Worksheet


    d1 = Timer
    Set wks = ActiveSheet
    Application.EnableEvents = False
    Application.ScreenUpdating = False

    'Make sure all rows are visible
    On Error Resume Next
    wks.ShowAllData
    wks.UsedRange.Rows.Hidden = False
    wks.UsedRange.Columns.Hidden = False
    On Error GoTo 0

    'Get concerned range
    Set r1 = wks.Range("A1:A35000")
    'Filter
    r1.AdvancedFilter Action:=xlFilterInPlace, Unique:=True

    'Get range of cells not to be deleted
    Set rKeepers = r1.SpecialCells(xlCellTypeVisible)
    On Error Resume Next
    wks.ShowAllData
    On Error GoTo 0
    rKeepers.EntireRow.Hidden = True

    'Delete all undesirables
    r1.SpecialCells(xlCellTypeVisible).EntireRow.Delete

    'show all rows
    On Error Resume Next
    wks.UsedRange.Rows.Hidden = False
    On Error GoTo 0

    Application.EnableEvents = False
    Application.ScreenUpdating = False

    Debug.Print Timer() - d1

End Sub

好的，以下是 Doc 和 Issun 对字典的使用。在我不相信之前，但在查看并测试它并与高级过滤器进行比较之后，我相信，字典更适合这个应用程序。我不知道为什么 Excel 在这一点上没有更快，因为他们应该使用更快的算法，而不是隐藏、取消隐藏行，因为这种情况发生得非常快。所以如果有人知道，请告诉我。这个过程在我的慢速计算机上只需要 1 秒多一点：

Sub FindDupesAndDelete()

    Dim d1 As Double
    Dim dict As Object
    Dim sh As Worksheet
    Dim v1 As Variant
'    Dim s1() As String
    Dim rDelete As Range
    Dim bUnion As Boolean

    d1 = Timer()
    bUnion = False
    Set dict = CreateObject("Scripting.Dictionary")
    Set sh = ActiveSheet
    v1 = Application.Transpose(sh.Range("A1", "A" _
          & sh.Cells.SpecialCells(xlCellTypeLastCell).row))

'    ReDim s1(1 To UBound(v1))

    Dim row As Long, value As String ', newEntry As Boolean
    For row = 1 To sh.Cells.SpecialCells(xlCellTypeLastCell).row
        value = v1(row)

        If dict.Exists(value) Then
'            newEntry = False
            If bUnion Then
                Set rDelete = Union(rDelete, sh.Range("A" & row))
            Else
                Set rDelete = sh.Range("A" & row)
                bUnion = True
            End If
        Else
'            newEntry = True
            dict.Add value, 1
        End If
'        s1(row) = newEntry

    Next
    rDelete.EntireRow.Delete
'    sh.Range("B1", "B" & UBound(v1)) = Application.Transpose(s1)
    Debug.Print Timer() - d1
End Sub

Answer 5

好的，现在我们有更多信息，这是一个解决方案。它应该几乎立即执行。

代码通过使用您的连接公式填充列 y 来工作。然后它将所有列 y 添加到字典中，并使用字典将每一行标记为列 z 中的重复项。然后删除第 35000 行之后找到的所有重复项。最后清除 y 列和 z 列以删除冗余数据。

Sub RemoveDuplicates()
    Dim vData As Variant, vArray As Variant
    Dim lRow As Long

    '// Get used range of column A (excluding header) and offset to get column y 
    With ActiveSheet.Range("A2", Cells(Rows.Count, "A").End(xlUp)).Offset(, 24)
        '// Adds the concatenate formula to the sheet column (y)
        .FormulaR1C1 = "=RC[-24]&RC[-23]&RC[-19]&RC[-18]&RC[-17]&RC[-16]"
        '// Adds the formula results to an array
        vData = .Resize(, 1).value
    End With

    '// Re dimension the array to the correct size 
    ReDim vArray(1 To UBound(vData, 1), 0)

    '// Create a dictionary object using late binding
    With CreateObject("Scripting.Dictionary")
        '// Loop through each row in the array
        For lRow = 1 To UBound(vData, 1)
            '// Check if value exists in the array
            If Not .exists(vData(lRow, 1)) Then
                '// Value does not exist mark as non duplicate.
                vArray(lRow, 0) = "x"
                '//  Add value to dictionary
                .Add vData(lRow, 1), Nothing
            End If
        Next lRow
    End With

    '// Turn off screen updating to speed up code and prevent screen flicker
    Application.ScreenUpdating = False    

    With ActiveSheet
        '// Populate column z with the array
        .Range("Z2").Resize(UBound(vArray, 1)) = vArray
        '// Use error handling as speciallcells throws an error when none exist.
        On Error Resume Next
        '// Delete all blank cells in column z
        .Range("Y35001", .Cells(Rows.Count, "Y").End(xlUp)).Offset(, 1).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
        '// Remove error handling
        On Error GoTo 0
        '// Clear columns y and z
        .Columns(25).Resize(, 2).ClearContents
    End With

   '// Turn screen updating back on.
   Application.ScreenUpdating = True
End Sub

注意：如果需要，您可以将所有引用“activesheet”更改为您的工作表代号。

注意 2：它假定您有标题并且只留下第 1 行。

我已尽我所能使用您的列和测试数据。这是我使用的测试填充：

Sub TestFill()

    For i = 1 To 37000
        With Range("A" & i)
            .value = Choose(Int(2 * Rnd + 1), "PTY", "GTY")
            .Offset(, 1).value = Round((40000 * (Rnd + 1)), Choose(Int(4 * Rnd + 1), 1, 2, 3, 4))
            .Offset(, 5).value = Int(4 * Rnd + 1)
            .Offset(, 6).value = Int(2 * Rnd + 1)
            .Offset(, 7).value = Choose(Int(2 * Rnd + 1), "230", "540")
            .Offset(, 8).value = Int(3 * Rnd + 1)
        End With
    Next i

End Sub

Answer 6

假设您在 A 列中有条目，并且您希望在 B 列中获得公式的结果（但要快得多）。这个 VBA 宏应该可以解决问题：

Option Explicit
Sub FindDupes()
    Dim dict As Object
    Dim sh As Worksheet
    Set dict = CreateObject("Scripting.Dictionary")
    Set sh = ActiveSheet

    Dim row As Long, value As String
    For row = 1 To sh.Cells.SpecialCells(xlCellTypeLastCell).row
        value = sh.Range("A" & row).Text
        If dict.Exists(value) Then
            sh.Range("B" & row) = "False"
        Else
            sh.Range("B" & row) = "True"
            dict.Add value, 1
        End If
    Next
End Sub

（使用字典在这里给出了几乎线性的运行时间，对于 35.0000 行，这应该是几秒钟的问题，而您的原始公式具有二次运行时间复杂度）。

编辑：由于您的评论：您必须首先通过阅读每个条目至少一次来填写字典，这是您无法轻易避免的事情。您可以避免的是在 B 列已经填满时再次填充它们：

Option Explicit
Sub FindDupes()
    Dim dict As Object
    Dim sh As Worksheet
    Set dict = CreateObject("Scripting.Dictionary")
    Set sh = ActiveSheet

    Dim row As Long, value As String, newEntry As Boolean
    For row = 1 To sh.Cells.SpecialCells(xlCellTypeLastCell).row
        value = sh.Range("A" & row).Text

        If dict.Exists(value) Then
            newEntry = False
        Else
            newEntry = True
            dict.Add value, 1
        End If
        If Trim(sh.Range("B" & row)) = "" Then sh.Range("B" & row) = newEntry
    Next
End Sub

但我怀疑这不会比我的第一个解决方案快多少。

Answer 7

现在您已经更新，希望删除整行，并且允许前 35000 行有欺骗，这里有一个函数可以为您做到这一点。我想我想出了一个聪明的方法，而且速度也很快：

Sub RemoveNewDupes()

Application.ScreenUpdating = False
Dim lastRow As Long
Dim varray As Variant
Dim oldDict As Object, newDict As Object
Set oldDict = CreateObject("scripting.dictionary")
Set newDict = CreateObject("scripting.dictionary")

On Error Resume Next
lastRow = Range("A" & Rows.Count).End(xlUp).Row

'Add old entries to dictionary
varray = Range("A1:A35000").Value
For i = 1 To UBound(varray, 1)
    oldDict.Add varray(i, 1), 1
Next

'Check for dupes
varray = Range("A35001:A" & lastRow).Value
For i = 35000 + UBound(varray, 1) To 35001 Step -1
    If oldDict.exists(varray(i - 35000, 1)) = True Or _
       newDict.exists(varray(i - 35000, 1)) = True Then
        Range("A" & i).EntireRow.Delete
    Else
        newDict.Add varray(i - 35000, 1), 1
    End If
Next

Application.ScreenUpdating = True

'A status message at the end for finishing touch
MsgBox UBound(varray, 1) - newDict.Count & _
" duplicate row(s) found and deleted."

End Sub

工作原理：

首先，我将 35000 个单元格存储到一个字典文件中。然后我将每个单元格 35001 的变体数组向前循环并向后循环以查看它是否在 35k 字典中，或者我们还没有在循环中遇到该值。如果它发现它是一个骗子，它会删除该行。

它执行行删除的最酷（如果我可以说）方式是，当您创建可变数组时，例如 A35001 - A37000，它将它们存储为 (1, 1) (2, 1) (... ）。因此，如果您将“i”设置为数组的 Ubound + 35000 并返回到 35001，您将循环遍历从 A37000 到 A35001 的所有添加。然后当你想删除行时，“i”完美地设置为找到值的行号，所以你可以删除它。而且由于它倒退，它不会搞砸循环！