使用 VBA 从数组中删除重复项

Remove duplicates from array using VBA

提问by Yht H

Assume I have a block of data in Excel 2010, 100 rows by 3 columns.

假设我在 Excel 2010 中有一个数据块，100 行 x 3 列。

Column C contains some duplicates, say it starts off as

C列包含一些重复项，说它开始于

1, 1, 1, 2, 3, 4, 5, ..... , 97, 98

1, 1, 1, 2, 3, 4, 5, ..... , 97, 98

Using VBA, I would like to remove the duplicate rows so I am left with 98 rows and 3 columns.

使用 VBA，我想删除重复的行，所以我只剩下 98 行和 3 列。

1, 2, 3, ..... , 97, 98

1, 2, 3, ..... , 97, 98

I know there is a button in Excel 2010 to do that but it inteferes with the rest of my code subsequently and gives incorrect results.

我知道 Excel 2010 中有一个按钮可以执行此操作，但它随后会干扰我的其余代码并给出不正确的结果。

Furthermore, I would like to do it in arrays, then paste the results on the worksheet, rather than methods such as Application.Worksheetfunction.countif(.....

此外，我想在数组中进行，然后将结果粘贴到工作表上，而不是诸如 Application.Worksheetfunction.countif(.....

So something like:

所以像：

Dim myarray() as Variant
myarray=cells(1,1).Currentregion.value

Dim a as Long

For a=1 to Ubound(myarray,1)

    'something here to 

Next a

回答by Zairja

I answered a similar question. Here is the code I used:

我回答了一个类似的问题。这是我使用的代码：

Dim dict As Object
Dim rowCount As Long
Dim strVal As String

Set dict = CreateObject("Scripting.Dictionary")

rowCount = Sheet1.Range("A1").CurrentRegion.Rows.Count

'you can change the loop condition to iterate through the array rows instead
Do While rowCount > 1
  strVal = Sheet1.Cells(rowCount, 1).Value2

  If dict.exists(strVal) Then
    Sheet1.Rows(rowCount).EntireRow.Delete
  Else
    'if doing this with an array, then add code in the Else block
    ' to assign values from this row to the array of unique values
    dict.Add strVal, 0
  End If

  rowCount = rowCount - 1
Loop

Set dict = Nothing

If you want to use an array, then loop through the elements with the same conditional (if/else) statements. If the item doesn't exist in the dictionary, then you can add it to the dictionary and add the row values to another array.

如果要使用数组，请使用相同的条件 (if/else) 语句循环遍历元素。如果该项目在字典中不存在，那么您可以将其添加到字典中并将行值添加到另一个数组中。

Honestly, I think the most efficient way is to adapt code you'd get from the macro recorder. You can perform the above function in one line:

老实说，我认为最有效的方法是改编您从宏记录器中获得的代码。您可以在一行中执行上述功能：

    Sheet1.UsedRange.RemoveDuplicates Columns:=3, Header:=xlYes

回答by RBILLC

Function eliminateDuplicate(poArr As Variant) As Variant
    Dim poArrNoDup()

    dupArrIndex = -1
    For i = LBound(poArr) To UBound(poArr)
        dupBool = False

        For j = LBound(poArr) To i
            If poArr(i) = poArr(j) And Not i = j Then
                dupBool = True
            End If
        Next j

        If dupBool = False Then
            dupArrIndex = dupArrIndex + 1
            ReDim Preserve poArrNoDup(dupArrIndex)
            poArrNoDup(dupArrIndex) = poArr(i)
        End If
    Next i

    eliminateDuplicate = poArrNoDup
End Function

回答by radoslav006

Answer from @RBILLC could be easily improved by adding an Exit Forinside internal loop:

通过添加Exit For内部内部循环可以轻松改进@RBILLC 的回答：

Function eliminateDuplicate(poArr As Variant) As Variant
    Dim poArrNoDup()

    dupArrIndex = -1
    For i = LBound(poArr) To UBound(poArr)
        dupBool = False

        For j = LBound(poArr) To i
            If poArr(i) = poArr(j) And Not i = j Then
                dupBool = True
                Exit For
            End If
        Next j

        If dupBool = False Then
            dupArrIndex = dupArrIndex + 1
            ReDim Preserve poArrNoDup(dupArrIndex)
            poArrNoDup(dupArrIndex) = poArr(i)
        End If
    Next i

    eliminateDuplicate = poArrNoDup
End Function

回答by Steve Joppich

I know this is old, but here's something I used to copy duplicate values to another range so that I could see them quickly to establish data integrity for a database I was standing up from various spreadsheets. To make the procedure delete the duplicates it would be as simple as replacing the dupRnglines with Cell.Delete Shift:=xlToLeftor something to that effect.

我知道这是旧的，但这是我用来将重复值复制到另一个范围的东西，以便我可以快速查看它们以建立我从各种电子表格中建立的数据库的数据完整性。要使该过程删除重复项，就像用或类似的东西替换dupRng行一样简单Cell.Delete Shift:=xlToLeft。

I haven't tested that personally, but it should work.

我还没有亲自测试过，但它应该可以工作。

Sub PartCompare()
    Dim partRng As Range, partArr() As Variant, i As Integer
    Dim Cell As Range, lrow As Integer

    lrow = ThisWorkbook.Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
    i = 0

    Set partRng = ThisWorkbook.Worksheets("Sheet1").Range(Cells(1, 1), Cells(lrow, 1))

    For Each Cell In partRng.Cells
        ReDim Preserve partArr(i)
        partArr(i) = Cell.Value
        i = i + 1
    Next

    Dim dupRng As Range, j As Integer, x As Integer, c As Integer

    Set dupRng = ThisWorkbook.Worksheets("Sheet1").Range("D1")

    x = 0
    c = 1
    For Each Cell In partRng.Cells
        For j = c To UBound(partArr)
            If partArr(j) = Cell.Value Then
                dupRng.Offset(x, 0).Value = Cell.Value
                dupRng.Offset(x, 1).Value = Cell.Address()
                x = x + 1
                Exit For
            End If
        Next j
        c = c + 1
    Next Cell
End Sub

回答by Sancarn

Simple function to remove duplicates from a 1D array

从一维数组中删除重复项的简单函数

Private Function DeDupeArray(vArray As Variant) As Variant
  Dim oDict As Object, i As Long
  Set oDict = CreateObject("Scripting.Dictionary")
  For i = LBound(vArray) To UBound(vArray)
    oDict(vArray(i)) = True
  Next
  DeDupeArray = oDict.keys()
End Function

回答by Andy Raddatz

Dictionaries have a max of 255 items, so if you have more values you need to use a Collection. Unfortunately, the Collection object does not have a .Contains(a) or .Exists(a) method, but this function handles (fakes it) it nicely by using the Error numbers:

字典最多有 255 个项目，所以如果你有更多的值，你需要使用集合。不幸的是，Collection 对象没有 .Contains(a) 或 .Exists(a) 方法，但该函数通过使用错误编号很好地处理（伪造）它：

CORRECTION: Dictionaries do not have such a limit (thanks Zairja). I may have been using an Integer to iterate through my Dictionary. In any event, this function allows you to check Collections for item existence, so I'll leave it here if it's useful to anyone:

更正：字典没有这样的限制（感谢 Zairja）。我可能一直在使用整数来遍历我的字典。无论如何，此功能允许您检查集合是否存在项目，因此如果对任何人有用，我会将其保留在这里：

CollContainsItem(col As Collection, val As Variant) As Boolean

Dim itm As Variant
On Error Resume Next

    itm = col.Item(val)
    CollContainsItem = Not (Err.Number = 5 Or Err.Number = 9)

On Error GoTo 0

End Function

So if you do need a Collection, you could likely just replace

所以如果你确实需要一个集合，你可能只是替换

dict.Exists(strVal)

with

和

CollContainsItem(coll, strVal)

and replace

并替换

Set dict = CreateObject("Scripting.Dictionary")

with

和

Set coll = CreateObject("Scripting.Collection")

And use the rest of Zairja's code. (I didn't actually try it but it should be close)

并使用 Zairja 的其余代码。（我实际上没有尝试过，但应该很接近）