Как получить уникальные значения из колонки VBA Excel

Savelev

Как получить уникальные значения из колонки таблицы в VBA Excel например в массив?

При работе в Excel при установке автофильтра, Excel моментом заполняет ListBox уникальными значениями, даже при большом заполнении таблицы.

Korolana

Sub FillArrayWithUniqueValue()
Dim MyArray() As Variant

Columns('A:A').Select ' select your column
Range('A1:A14').AdvancedFilter Action:=xlFilterInPlace, Unique:=True ' filter on this column to receive unique values
' part of rows will be hidden and I need not include them into my next selection

ActiveCell.CurrentRegion.Select ' copy unique values from this column to some free temporary place and select this region
nRow = Selection.Rows.Count
Selection.Copy
ActiveSheet.Paste Destination:=Cells(nRow + 2, 2)
Cells(nRow + 2, 2).Select
ActiveCell.CurrentRegion.Select


MyArray = Selection 'fill my array with our unique values from Excel
ActiveCell.CurrentRegion.Clear ' clear our temporary region
ActiveSheet.ShowAllData ' clear our filter


End Sub

Now, all your data in two-dimensial array.
In this case, you can see your data it in Myarray(1,1), MyArray(2,1)...and so on

Savelev

Спасибо за пример.

yuniki

Я это делаю по другому (нужно для заполнения списков в контролах):

' Выбирает из заданого именованного диапазона с заголовком RngName
' столбик fldName и отбирает только уникальные его значения
' в массиве aSel (<размер массива>,<Значение1>,...)
' Структура именованного диапазона :
' <ИмяСтолбца1 ><ИмяСтолбца2>...
' <ЗначСтолбца1><ЗначCтолбца2>...

Public Function UnicSelect(ByRef rngName As String, ByRef fldName As String, _
ByRef aSel() As Variant, _
Optional ByRef strSQL As String = '')
Dim cnn As ADODB.Connection, Rs As ADODB.Recordset, i As Long
Set cnn = New ADODB.Connection
cnn.Open 'Provider=Microsoft.Jet.OLEDB.4.0;' & _
'Data Source=' & _
ActiveWorkbook.Path + ' ' + ActiveWorkbook.Name & ';' & _
'Extended Properties=Excel 8.0' 'HDR=Yes;'
Set Rs = New ADODB.Recordset
Rs.Open Source:='SELECT distinct ' & fldName & ' from ' & rngName, _
ActiveConnection:=cnn, _
CursorType:=adOpenDynamic, _
LockType:=adLockReadOnly, _
Options:=adCmdText
ReDim Preserve aSel(0) ' инициализация массива
aSel(0) = 0 ' 0-й элемент хранит размер массива
i = 0
Rs.MoveFirst
Do While Not Rs.EOF
ReDim Preserve aSel(i + 1)
aSel(UBound(aSel)) = Rs.Fields(fldName)
Rs.MoveNext: i = i + 1
Loop
aSel(0) = UBound(aSel) '
Rs.Close: cnn.Close: Set Rs = Nothing: Set cnn = Nothing
End Function ' UnicSelect -->>

Korolana

This way is right too, but much slower. Try it.

maks_well

Попробуй на скорость это
По-моему алгоритм уже был когда-то на этом форуме

Sub FormSpisok(ListName, FirstRow, NumColumn, Spisok)

'Формирует (в массив Spisok) список строк неповторяющихся значений из листа ListName в столбце NumColumn, начиная с ряда FirstRow
'Ограничение на листе-первое пустое значение
'Первое значение массива Spisok(0)-кол-во значений

Dim numb As Integer
Dim stroka As String
Dim DataValues As New Collection

ReDim Spisok(1)
Spisok(0) = 0

stroka = Trim(Sheets(ListName).Cells(FirstRow, NumColumn))
On Error Resume Next
Do While stroka <> ''
DataValues.Add stroka, stroka
FirstRow = FirstRow + 1
stroka = Trim(Sheets(ListName).Cells(FirstRow, NumColumn))
Loop
On Error GoTo 0

numb = 1
For Each DataValue In DataValues
ReDim Preserve Spisok(numb + 1)
Spisok(numb) = DataValue
numb = numb + 1
Next
Spisok(0) = numb - 1
End Sub

Serg_FSM

Приветствую.
Несколько измененый вариант, предложенный Короланой, извлекает уникальные значения из столбца с активной ячейкой:

Код Code
1 2 3 4 5 Public Sub FillArrayWithUniqueValue() Dim MyArray() As Variant ActiveCell.EntireColumn.AdvancedFilter Action:=xlFilterCopy, copytorange:=Cells(2, 4), unique:=True 'filter for current column MyArray = Cells(2, 4).CurrentRegion.Value Cells(2, 4).CurrentRegion.Clear ' clear our temporary region

правда не работает если первая ячейка пустая и еще можно потерять часть значений (из-за использования CurrentRegion) если среди уникальных есть пустая ячейка (хотя если перед заполнением массива отсортировать temporary region, то может получиться)

wanton2

как уникальные найти я понял...
а как отметить строки *дубликатов* каким - ниб. цветом???
можно найти unique-> Selection.покрасить-> ShowAllData-> если не закрашено, то закрасить своим цветом....
но если 4 дубликата, то незакр. будет 3!!!
как сделать 'красиво'?

что то я туплю мало-мало... ;-/

гуру, подскажите, плз!

заранее, 10х!