В продолжение темы И снова уникальные значения в массиве (vba) - отсюда имеется код, собирающий уникальные из столбца и присваивающий всем значениям порядковые номера. Хотел бы упростить код, чтобы в массиве находились только уникальные (без порядковых номеров), многое перепробовал. Изменение Resize(x - 1, 2) на (x - 1, 1) на содержимое массива не влияет
Конечная цель - использовать массив для организации цикла по уникальным значениям (цикл For Each x In arr2 отрабатывает повторное количество итераций по несуществующим критериям, предполагаю, что по присвоенным номерам, т.к. кол-во лишних операций равно размеру массива уникальных), продолжаю искать решение
Код
Sub qqq()
Dim Uniq As New Collection, LastRow As Long, i As Long, j As Long, iValue, Arr(), Arr2(), x
LastRow = Cells(Rows.Count, 1).End(xlUp).Row
Arr = Range(Cells(2, 1), Cells(LastRow, 1)).Value
For i = 1 To UBound(Arr, 1)
On Error Resume Next
Uniq.Add Arr(i, 1), CStr(Arr(i, 1))
Next
ReDim Arr2(1 To Uniq.Count, 1 To 2)
x = 1
For i = 1 To Uniq.Count
iValue = Uniq(i)
For j = 1 To UBound(Arr, 1)
If Arr(j, 1) = iValue Then
Arr2(x, 1) = iValue
Arr2(x, 2) = i '+ 1
x = x + 1
Exit For
End If
Next
Next
[E2].Resize(x - 1, 2) = Arr2
End Sub
Здравствуйте. Если надо просто убрать из выходного массива номера уникальных элементов, то, кмк, это можно сделать так:
Код
Sub qqq()
Dim Uniq As New Collection, LastRow As Long, i As Long, j As Long, iValue, Arr(), Arr2(), x
LastRow = Cells(Rows.Count, 1).End(xlUp).Row
Arr = Range(Cells(2, 1), Cells(LastRow, 1)).Value
For i = 1 To UBound(Arr, 1)
On Error Resume Next
Uniq.Add Arr(i, 1), CStr(Arr(i, 1))
Next
ReDim Arr2(1 To Uniq.Count, 1 To 1)
x = 1
For i = 1 To Uniq.Count
iValue = Uniq(i)
For j = 1 To UBound(Arr, 1)
If Arr(j, 1) = iValue Then
Arr2(x, 1) = iValue
' Arr2(x, 2) = i '+ 1
x = x + 1
Exit For
End If
Next
Next
[E2].Resize(x - 1, 1) = Arr2
End Sub
Но после прочтения окончательной "хотелки" создается впечатление, что вы излишне что-то наворачиваете. Если нужны уникальные значения - так не нужен тогда второй массив - вот мы в коллекцию Uniq запихнули все уникальные элементы из первого массива - вот вам и их перечень, вот по каждому элементу коллекции Uniq и делайте, что нужно.
Sub qqq()
Dim LastRow&, i&, Arr(), x&
LastRow = Cells(Rows.Count, 1).End(xlUp).Row
Arr = Range(Cells(2, 1), Cells(LastRow, 1)).Value
With CreateObject("scripting.dictionary")
For i = 1 To UBound(Arr, 1)
If Not .exists(CStr(Arr(i, 1))) Then x = x + 1: .Item(CStr(Arr(i, 1))) = x
Next
[E2].Resize(.Count, 2) = Application.Transpose(Array(.keys, .items))
End With
End Sub
Дмитрий Марков написал: Хотел бы упростить код, чтобы в массиве находились только уникальные (без порядковых номеров)
Код
Sub qqq()
Dim arr(), I&, iTemp
arr = Range("A2:A" & Cells(Rows.Count, 1).End(xlUp).Row).Value
On Error Resume Next
With CreateObject("scripting.dictionary")
For I = 1 To UBound(arr): iTemp = .Item(arr(I, 1)): Next
Range("E2").Resize(.Count) = Application.Transpose(.Keys)
End With
End Sub
Согласие есть продукт при полном непротивлении сторон