G oldenAxe
Member

Откуда:
Сообщений: 62

Существует в Экселе столбец с набором значений (как цифр так и слов). Иногда эти значения повторяются. Количество строк со значениями например 10000, из них уникальных примерно 500,
при чем повторяющиеся значения не всегда идут друг за другом.

Вопрос: Как из этого столбца быстро выдернуть в новый столбец уникальные значения?

Предполагаю что надо через Коллекцию действовать, но опыта ее использования нет никакого.

Подскажите как это сделать?

пока думаю как-то так:

sub collection()

Dim strCnt As Integer

strCnt = Range(cells(1,1),cells(1,1).End(xlDown).Count ' подсчет количества строк в массиве

Dim Mass() As String

ReDim Mass(1 To w)

Dim Coll As Collection

For i = 1 to w

coll.Add Mass(i) ' загрузка массива в коллекцию

Next i

For j = 1 to coll.Count

Cells(j,2) = coll(j)

next j

end sub

Что тут не так? как правильно???

A ntonariy
Member

Откуда: ☭
Сообщений: 67406

On Error Resume Next

For i = 1 to w

coll.Add Mass(i), CStr(i) ' загрузка массива в коллекцию

Next i

On Error Goto 0

В коллекции останутся уникальные значения.

G oldenAxe
Member

Откуда:
Сообщений: 62

Да, обработку ошибок добавил, но во второй столбец все равно уникальные значения не вываливаются...

не работает coll.Count
Как выяснить количество уникальных значений в коллекции?

A ntonariy
Member

Откуда: ☭
Сообщений: 67406

Наверное потому что коллекция пустая? Как значения попадают в массив?

G oldenAxe
Member

Откуда:
Сообщений: 62

Да вот в этом и был изначальный вопрос...

Как добавлять элементы из столбца в коллекцию???

M elkiades
Member

Откуда: Москва
Сообщений: 1555

Что значит не работает coll.Count? Выдает ноль?
В коллекции каждый ключ уникален.
Вы вообще-то какие-то значения вместо Mass(i) подставляете? Может, приведете весь код?

G oldenAxe
Member

Откуда:
Сообщений: 62

Все, вроде получилось... вот так все работает:

Sub X()

Dim avarItems(1 To 100) As Variant

Dim col As New collection

Dim intI As Integer

Randomize

Debug.Print "Исходные данные:"

On Error Resume Next

For intI = 1 To 100

avarItems(intI) = Cells(intI, 1)

Debug.Print avarItems(intI)

col.Add avarItems(intI), CStr(avarItems(intI))

Next intI

Debug.Print "Уникальные значения:"

For intI = 1 To col.Count

Cells(intI, 2) = col.Item(intI)

Next intI

End Sub

Но проблема этого макроса в том, что надо жестко задавать количество строк в исходном столбце... А мне надо чтоб он сам определял это количество...

я пробовал вместо "100" вставлять w = Range(Cells(1, 7), Cells(1, 7).End(xlDown)).Count, но VBA пишет ошибку...

В asiС
Member

Откуда: Königsberg
Сообщений: 104

Можно всё сделать проще. В VBA проекте нужно в Rferences поставить галочку напротив Microsoft ActiveX Data Objects Далее, в обрабатываемом столбце, самое верхнее поле должно назваться Mass (лучше A1 - Mass , A2...An - сами данные)
Ну и собственно, нужно запустить этот код при открытой странице.
Здесь производится SQL запрос к Excel и выбираются только уникальные значения в столбце Mass
Вроде всё, удачи!

Private Sub cmbSqlQuery()

Dim con As ADODB.Connection: Set con = New ADODB.Connection 'Коннект

Dim rs As ADODB.Recordset: Set rs = New ADODB.Recordset

Dim i As Integer

con.Open "Driver={Microsoft Excel Driver (*.xls)};DriverId=790;Dbq=" & ActiveWorkbook.FullName

rs.Open Replace("SELECT DISTINCT Mass FROM " & ActiveSheet.name & "$"), con, adOpenDynamic, adLockOptimistic

Workbooks.Add

'Вставка рекордсета в новый лист

For i = 0 To rs.Fields.Count - 1: Cells(1, i + 1).Value = rs.Fields(i).Name: Next i

ActiveSheet.Range("A2").CopyFromRecordset rs

rs.Close: Set rs = Nothing

con.Close: Set con = Nothing

End Sub

В asiС
Member

Откуда: Königsberg
Сообщений: 104

Ошибся в одной строке:
вместо
rs.Open Replace("SELECT DISTINCT Mass FROM " & ActiveSheet.name & "$"), con, adOpenDynamic, adLockOptimistic

нужно:

rs.Open ("SELECT DISTINCT Mass FROM " & ActiveSheet.name & "$"), con, adOpenDynamic, adLockOptimistic

R USYA
Member

Откуда: Харьков
Сообщений: 424

Ну и я 5 копеек втулю :)

Private Sub Command1_Click()

Dim SourceArray() As String 'Исходный массив

Dim TmpArray() As String 'Временный массив

SourceArray = Split(Text1, " ") 'Разбиваем текст на массив слов

ReDim TmpArray(UBound(SourceArray)) 'Выделяем память столько же, сколько и под исходный

Dim i As Long, j As Long, flag As Boolean, c As Long

For i = 0 To UBound(SourceArray) 'В цыкле удаляем дубликаты

For j = 0 To UBound(TmpArray)

If SourceArray(i) = TmpArray(j) Then flag = True: Exit For

Next j

If flag = False Then 'Значит нету там этого слова...

TmpArray(c) = SourceArray(i): c = c + 1

End If

flag = False

Next i

'Обрежим массив по кол-ву уникальных слов

ReDim Preserve TmpArray(c - 1)

'Соберём массив в текст

Text2 = Join(TmpArray, " ")

End Sub

Это правда удаляет повторяющиеся слова в тексте, но принцип там такой же...