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.Well它工作但是我不知道出了什么问题代码对某些条目不起作用。它甚至有时为唯一条目显示False。

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

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

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列的dupes，如果它们是相同的我必须删除行，我不应该打扰其他列c，d等所以我做的是我已使用一个未使用的列Y并使用这些

将这6个列的值连接到Y列的1

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

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

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

   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（来自最后一个）是原始记录的副本（最初是PTY）所以我要删除它。最后一个新条目是新条目本身的副本所以我应该删除即便如此。在上面的代码中，我必须只删除最后两行，这些行是原始记录的dupe，也是从中删除的。但是不应该删除作为欺骗的GTY但是在原始记录中。

我想我现在已经明确表达了看法。将它们连接成一个单元格。是更好的方法吗？对于仅仅2秒的40000个条目的conactenatin，我认为这无关紧要，但对这些的更多算法是非常值得尊重的

我听说国民对待45.00和45.00000不同的是，这可能是问题吗？因为我的数据中有小数点。我想我应该做

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

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

Answer 1

这也是对其他成员提出的一些评论和解决方案的回应，如果它没有立即回答你的问题，那就很抱歉。

首先，我认为在数据库场景中使用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

如果我们谈论高级过滤器与阵列＆amp; dictonary方法然后高级过滤器将更快与较少的行，但一旦你超过一定数量的行，那么数组方法将更快。然后看看当你改变重复数量时会发生什么.... :) 作为指南或一般规则使用excels内置函数会更快，我建议总是开发尝试使用这些内置函数，但是通常有例外，如上面删除重复项时。：）

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

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 2

BIG UPDATE ：

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

如果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条旧记录包括dupes并且你只想允许这些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 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值，然后删除可见的单元格。这可能是最快的方式。

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

Answer 4

好的，这是advancedfilter方法。不知道它是否比字典方法更快。不过要知道它会很有趣，所以在你尝试之后让我知道。我还包括删除部分，因此如果要进行真正的比较，则必须停止该部分。此外，你可以将它变成一个函数而不是一个子函数并输入变量，但是你想要改变它。

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字典中，或者我们还没有在循环中遇到该值。如果它发现它是一个欺骗，它会删除该行。

它删除行的方式很酷（如果我可以说），当您创建varray时，例如A35001 - A37000，它将它们存储为（1,1）（2,1）（... ）。因此，如果将“i”设置为阵列的Ubound + 35000并退回到35001，则将从A37000向后循环所有添加到A35001。然后，当您要删除行时，“i”完美地设置为找到值的行号，因此您可以删除它。而且由于它向后移动，它不会搞砸循环！

需要更好的优化代码？

7 个答案: