需要更好的优化代码？

Question

需要一个优化的代码.我有一个项目,我已经成功地使用它与vba(主要由stackoverflow程序员帮助,谢谢你)但今天我得到了一个反馈.它在记录中删除了2个更独特的条目但我不知道为什么它删除它们.

我应用的算法

我使用了我在谷歌上找到的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告诉我它不是ac或其他语言使其优化,但我需要代码,使我的代码更优化

我需要代码来解决这些问题,任何人都可以帮助我,因为我的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列的欺骗,如果它们是相同的我必须删除行,我不应该打扰其他列c,d等所以我做的是我已经使用了一个未使用的列Y并使用这些将这6个列的值连接成Y列中的1

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

现在检查Y列是否为dupes并删除整行.据我所知,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)所以我hava删除它.最后一个新条目是新条目本身的副本所以我应该删除它甚至.在上面的代码中,我必须只删除最后两行,这些行是原始记录的dupe,也是从中删除的.但是不应该删除作为欺骗的GTY但是在原始记录中.

我想我现在已经明确表达了看法.将它们连接成一个单元格.是更好的方法吗？作为40000个条目的conactenatin仅用了2秒钟我认为这无关紧要但是对这些算法的任何更多算法都是非常普遍的

我听说国民对待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

如果我们讨论的是高级过滤器与数组和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

大新闻:

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

• 如果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的建议并让我重新审视.