Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
Уникальные значения в массиве (vba), тема в архиве: И снова уникальные значения в массиве (vba)
 
#1
16.01.2019 17:43:42
Коллеги, добрый день,

В продолжение темы И снова уникальные значения в массиве (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
Изменено: Дмитрий Марков - 16.01.2019 23:11:35
 
 
 
#2
16.01.2019 17:50:12
Здравствуйте. Если надо просто убрать из выходного массива номера уникальных элементов, то, кмк, это можно сделать так:
Код
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 и делайте, что нужно.
Кому решение нужно - тот пример и рисует.
 
 
 
#3
16.01.2019 18:07:56
Цитата
Пытливый написал:
по каждому элементу коллекции Uniq и делайте, что нужно
Пытливый, Вы правы, я излишне взялся за arr2, в то время как мне нужен только Uniq, с первой попытки всё прошло как надо! Большое Вам спасибо!  
 
 
 
#4
16.01.2019 23:10:04
А можно вот так на словарях

Скрытый текст
Изменено: Nordheim - 16.01.2019 23:10:31
"Все гениальное просто, а все простое гениально!!!"
 
 
 
#5
17.01.2019 09:41:47
Nordheim, большое Вам спасибо за метод, повод услышать мнения, где методы эффективны))
 
 
 
#6
17.01.2019 09:48:03
Цитата
Дмитрий Марков написал:
Хотел бы упростить код, чтобы в массиве находились только уникальные (без порядковых номеров)
Код
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
Согласие есть продукт при полном непротивлении сторон
 
 
 
Страницы: 1
Наверх