VBA Excel - заполнить массив одним значением из отфильтрованного столбца с несколькими значениями

Question

Я пытаюсь заполнить массив некоторыми значениями, которые находятся в столбце в отфильтрованной таблице Excel. Проблема в том, что в этом столбце значения могут появляться несколько раз, но мне нужно возвращать только уникальные значения, а не все вхождения каждого значения.

Column F
a
a
a
b
c
c
a
b
d

Массив будет иметь переменную длину и, основываясь настолбец примера будет иметь элементы: {a, b, c, d}

Длина массива не может быть фиксированной, поскольку моя функция работает с отфильтрованной таблицей, длина которой варьируется. Иногда может быть только одно уникальное значение, в других случаях может быть 3.

Мне нужно сделать это, потому что мой массив будет использоваться для определения темы сообщения с помощью "..." и массива.

Я только начал с VBA.

Может кто-нибудь объяснить, как извлечь в массив только уникальные значения из столбца?

Answer 1

Использовать Scripting.Dictionary

Вы можете выбрать все данные из столбца с помощью sht.Cells(sht.Rows.Count, "F").End(xlUp).Row, а затем использовать Scripting.Dictionary, чтобы найти свои уникальные значения. Вот код:

'Main Routine
Sub MyMacro()
    Dim sht As Worksheet
    Dim column As Range
    Dim LastRow As Long
    Dim uniqueValues() As Variant

    Set sht = ActiveSheet 'Set your sheet here

    LastRow = sht.Cells(sht.Rows.Count, "F").End(xlUp).Row
    Set column = Range("F1:F" & LastRow)
    uniqueValues = getUniqueValues(column)
    'Do what you need to do with your values [...]
End Sub

'Return unique values from a Range
Function getUniqueValues(column As Range)
    Dim dict As New Scripting.Dictionary ' requires "Microsoft Scripting Runtime"
    Dim cell As Range

    For Each cell In column
        dict(cell.Value) = "1"
    Next

    'A double Transpose will put your data in an Array() format
    getUniqueValues = Application.Transpose(Application.Transpose(dict.Keys))
End Function

Если вы не хотите импортировать Microsoft Scripting Runtime, используйте этот код для объявления dict:

    'If you don't want to import Scripting Runtime, use this code
    Dim dict As Object
    Set dict = CreateObject("Scripting.Dictionary")

Примечание: Это проверено и отлично работает.

Надеюсь, это поможет.

Answer 2

вы можете использовать Scripting.Dictionary для такой задачи и xlCellTypeVisible, например:

Sub sometest()
    Dim x As Long, cl As Range
    Dim dic As Object: Set dic = CreateObject("Scripting.Dictionary")
    dic.comparemode = vbTextCompare

    x = Cells(Rows.Count, "A").End(xlUp).Row

    For Each cl In Range(Cells(2, "A"), Cells(x, "A")).SpecialCells(xlCellTypeVisible)
        If Not dic.exists(cl.Value) Then
            dic.Add cl.Value, Nothing
        End If
    Next cl

    Debug.Print Join(dic.keys, ",")

End Sub

тест: