VBA - удалить повторяющиеся значения массива

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

Поскольку ваши данные уже отсортированы, вы также можете использовать объект 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 2

лоток этот код пожалуйста:

    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

Answer 3

Используйте этот простой трюк, чтобы сделать массив 1D уникальным:

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