Question

我想删除排序数组的重复值。

这是用于按升序对值进行排序的代码。

Dim k As Integer
Dim j As Integer
Dim sortedArray As Variant
Dim sorting As Boolean

If sorting = True Then
 For j = LBound(concentrationArray) To UBound(concentrationArray)
  For k = j + 1 To UBound(concentrationArray)
   If concentrationArray(j) < concentrationArray(k) Then
    sortedArray = concentrationArray(j)
    concentrationArray(j) = concentrationArray(k)
    concentrationArray(k) = sortedArray           
   End If
  Next k
 Next j
ElseIf sorting = False Then
 For j = LBound(concentrationArray) To UBound(concentrationArray)
  For k = j + 1 To UBound(concentrationArray)
   If concentrationArray(j) > concentrationArray(k) Then
    sortedArray = concentrationArray(k)
    concentrationArray(k) = concentrationArray(j)
    concentrationArray(j) = sortedArray
   End If
  Next k
 Next j
End If

但是，从这些排序后的数组中，它们可能包含重复的值，我想将其删除。

For j = LBound(concentrationArray) To UBound(concentrationArray)
 For k = j + 1 To UBound(concentrationArray)
  If concentrationArray(j) <> concentrationArray(k) Then
   sortedArray = concentrationArray(j)
   concentrationArray(j) = concentrationArray(k)
   concentrationArray(k) = sortedArray
  ElseIf concentrationArray(j) = concentrationArray(k) Then
   sortedArray = concentrationArray(j)
   concentrationArray(j) = concentrationArray(k + 1)
   ReDim concentrationArray(LBound(concentrationArray) To UBound(concentrationArray) - 1) As Variant
   concentrationArray(k) = sortedArray
  End If
 Next k
Next j

我不明白为什么这会返回错误。

有人可以帮忙吗？

预先感谢

--------------------------已解决-------------------- ------

这是使其工作的另一种方式：

j = LBound(concentrationArray)

While j < UBound(concentrationArray)
 If concentrationArray(j) = concentrationArray(j+1) Then
  Call DeleteElementArray(j, concentrationArray)
 End If
 j = j + 1
Wend

Public Sub DeleteElementArray(ByVal arrIndex as Integer, ByRef myArr as Variant)
Dim p as Long

 For p = arrIndex+1 To Ubound(myArr)
  myArr(p-1) = myArr(p)
 Next p

Answer 1

使用以下简单技巧使一维数组唯一：

Function Unique(aFirstArray() As Variant)
'Collections can be unique, as long as you use the second Key argument when adding items.
'Key values must always be unique, and adding an item with an existing Key raises an error:
'hence the On Error Resume Next

    Dim coll As New Collection, a
    Dim tempArray() As Variant  'aFirstArray(),
    Dim i As Long

'    aFirstArray() = Array("Banana", "Apple", "Orange", "Tomato", "Apple", _
'    "Lemon", "Lime", "Lime", "Apple")

    On Error Resume Next
    For Each a In aFirstArray
       'Debug.Print a
       coll.Add a, a
    Next

    ReDim aFirstArray(coll.count)

    For i = 1 To coll.count
       'Cells(i, 1) = coll(i)
       aFirstArray(i) = coll(i)
    Next

End Function

Answer 2

由于已经对数据进行了排序，因此您也可以使用ArrayList对象，然后使用.toArray一次性提取所有项目。您可以使用.Contains方法仅添加唯一项。

Option Explicit
Public Sub DeDuplicateArray()
    Dim sortedArray(), i As Long, sList As Object, arr()
    sortedArray = Array(0, 0, 1, 2, 2, 3)
    Set sList = CreateObject("System.Collections.ArrayList")
    For i = LBound(sortedArray) To UBound(sortedArray)
        If Not sList.contains(sortedArray(i)) Then sList.Add sortedArray(i)
    Next
    arr = sList.toArray
    Debug.Print UBound(arr)
End Sub

如果未对数据进行排序，则可以使用SortedList的测试来排除重复项，从而将其添加到.Contains对象中。

Option Explicit
Public Sub DeDuplicateArray()
    Dim sortedArray(), i As Long, sList As Object
    sortedArray = Array(0, 0, 1, 2, 2, 3)
    Set sList = CreateObject("System.Collections.SortedList")
    For i = LBound(sortedArray) To UBound(sortedArray)
        If Not sList.contains(sortedArray(i)) Then sList.Add sortedArray(i), vbNullString
    Next
    Debug.Print sList.Count
End Sub

Answer 3

请输入此代码：

    Option Explicit

Sub ifDublicate()
Dim i, lRow As Integer
Dim actuellCell, cellInArray As Variant
Dim countValues, deleted As Double

'Dim arr ()
'lRow = ActiveSheet.Range("A" & Range("A:A").Rows.Count).End(xlUp).Row
'arr = Range("A1:A" & lRow)

Dim arr(10) As Variant ' or array from worksheet
   arr(0) = "Apple"
   arr(1) = "Orange"
   arr(2) = "Apple"
   arr(3) = "Apple"
   arr(4) = "beans"
   arr(5) = "beans"
   arr(6) = "Orange"
   arr(7) = "Orange"
   arr(8) = "sandwitch"
   arr(9) = "coffee"
   arr(10) = "nuts"

For i = 0 To UBound(arr)
    actuellCell = arr(i)
    If InStr(cellInArray, actuellCell) > 0 Then
'        ActiveSheet.Cells(i, 2) = "Already Exists"
        deleted = deleted + 1
    Else
        cellInArray = CStr(cellInArray) & "," & CStr(actuellCell)
        countValues = countValues + 1
        If Left(cellInArray, 1) = "," Then
            cellInArray = Right(cellInArray, Len(cellInArray) - 1)
        End If
    End If

Next i

MsgBox "Array after remove dublicate: " & cellInArray & vbNewLine & _
        "Count Values without dublicate: " & countValues & vbNewLine & _
        "deleted: " & deleted & vbNewLine & _
        "lase value: " & actuellCell

End Sub

VBA-删除数组的重复值

3 个答案: