Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel (архив)
Страницы: 1
RSS
отбор уникальных значений из диапазона
 
#1
21.09.2011 00:12:17
Помогите, пожалуйста, решить следующую проблему.  
Дано:  
столбец из n кол-ва строк, где много повторяющихся значений, необходимо отобрать уникальные значения из этого множества и записать их в массив. Похоже на "Удалить дубликаты" в Excel 2007, но реализовать надо в VBA  
 
Пробовал реализовать это следующим образом:  
 
 
Dim MasUniqueZnach()  
 
tec = 2 ' строка, с которой начинаются необходимые значения  
cntZnach = 0  
 
While Not Range("a" + CStr(tec)) = Empty  
     
   Naim = Range("a" + CStr(tec))  
     
   For x = 0 To cntZnach  
     
       If MasGroup(x) = Naim Then  
           Exit For  
           Else  
              ReDim Preserve MasZnach(x)  
              MasZnach(x) = Naim  
              cntZnach = cntZnach + 1  
       End If  
     
   Next x  
         
tec = tec + 1  
Wend  
 
Не вышло, хотя когда-то уже сталкивался с подобной задачей, писал похожий код.
 
 
 
#2
21.09.2011 00:24:02
Для таких дел есть коллекции и словари. Сразу за один проход получаем уникальные, которые потом можно или сразу выгрузить на лист (если не десятки тысяч, а то transpose сглючит), или сразу в процессе отбора в словарь/коллекцию набирать в массив.  
Вот хороший материал от Alex_ST - http://www.excelworld.ru/forum/3-313-1
 
 
 
#3
21.09.2011 11:33:44
http://www.planetaexcel.ru/forum.php?thread_id=31640
Чебурашка стал символом олимпийских игр. А чего достиг ты?
Тишина - самый громкий звук

https://github.com/nervgh
 
 
 
#4
21.09.2011 12:29:41
morkostya, и правильно делаете, что поиском не пользуетесь.  
Зачем прилагать усилия, когда добрые форумчане с удовольствием поищут для вас готовые решения (коих в инете тысячи)...  
 
http://excelvba.ru/code/UniqueValuesFromArray
Надстройки для Excel  Парсинг сайтов  Мониторинг цен конкурентов
 
 
 
#5
21.09.2011 12:46:09
Я пользуюсь этим. Сделано по материалам форума :-). Вставил в контекстное меню - очень доволен  
 
Sub ОтборУникальныхЗначений()  
' Программа отбирает уникальные значения из выделения, сортирует и вставляет из в указанное место  
Dim InRange As Range, cell As Range, OutRange As Range  
Dim NoDupes As New Collection  
Dim ND() As String, MSG As String  
Dim i As Integer, j As Integer  
Dim Swap1, Swap2  
 
Set InRange = Selection 'предварительно выделенный диапазон  
On Error Resume Next  
For Each cell In InRange 'Используется свойство коллекшен принимать только уникальные значения  
   NoDupes.Add cell.Value, CStr(cell.Value)  
Next cell  
On Error GoTo 0  
 
MSG = "Всего элементов: " & InRange.Count & vbCrLf  
MSG = MSG & "Уникальных элементов: " & NoDupes.Count  
MsgBox MSG, , "Выделено"  
     
For i = 1 To NoDupes.Count - 1 'пузырьковая сортировка массива уникальных значений  
   For j = i + 1 To NoDupes.Count  
       If NoDupes(i) > NoDupes(j) Then  
           Swap1 = NoDupes(i)  
           Swap2 = NoDupes(j)  
           NoDupes.Add Swap1, before:=j  
           NoDupes.Add Swap2, before:=i  
           NoDupes.Remove i + 1  
           NoDupes.Remove j + 1  
       End If  
   Next j  
Next i  
 
ReDim ND(NoDupes.Count) 'перемещаем коллекцию в массив  
For i = 1 To NoDupes.Count  
   ND(i) = NoDupes.Item(i)  
Next i  
 
On Error Resume Next  'куда вставлять отобранные и сортированные данные  
Set OutRange = Application.InputBox(Prompt:="Выделите ячейку, куда вставить данные", _  
   Title:="Куда вставить?", Type:=8)  
On Error GoTo 0  
 
If OutRange Is Nothing Then ' если нажата кнопка "отмена"  
   MsgBox "Действие отменено"  
Else ' Выводим выходной массив в указанное место  
   OutRange.Resize(NoDupes.Count, 1).Value = WorksheetFunction.Transpose(ND)  
End If  
 
End Sub
 
 
 
#6
21.09.2011 13:33:13
{quote}{login=Серега}{date=21.09.2011 12:46}{thema=}{post}Я пользуюсь этим. Сделано по материалам форума :-). Вставил в контекстное меню - очень доволен  
 
Sub ОтборУникальныхЗначений()  
' Программа отбирает уникальные значения из выделения, сортирует и вставляет из в указанное место  
Dim InRange As Range, cell As Range, OutRange As Range  
Dim NoDupes As New Collection  
Dim ND() As String, MSG As String  
Dim i As Integer, j As Integer  
Dim Swap1, Swap2  
 
Set InRange = Selection 'предварительно выделенный диапазон  
On Error Resume Next  
For Each cell In InRange 'Используется свойство коллекшен принимать только уникальные значения  
   NoDupes.Add cell.Value, CStr(cell.Value)  
Next cell  
On Error GoTo 0  
 
MSG = "Всего элементов: " & InRange.Count & vbCrLf  
MSG = MSG & "Уникальных элементов: " & NoDupes.Count  
MsgBox MSG, , "Выделено"  
     
For i = 1 To NoDupes.Count - 1 'пузырьковая сортировка массива уникальных значений  
   For j = i + 1 To NoDupes.Count  
       If NoDupes(i) > NoDupes(j) Then  
           Swap1 = NoDupes(i)  
           Swap2 = NoDupes(j)  
           NoDupes.Add Swap1, before:=j  
           NoDupes.Add Swap2, before:=i  
           NoDupes.Remove i + 1  
           NoDupes.Remove j + 1  
       End If  
   Next j  
Next i  
 
ReDim ND(NoDupes.Count) 'перемещаем коллекцию в массив  
For i = 1 To NoDupes.Count  
   ND(i) = NoDupes.Item(i)  
Next i  
 
On Error Resume Next  'куда вставлять отобранные и сортированные данные  
Set OutRange = Application.InputBox(Prompt:="Выделите ячейку, куда вставить данные", _  
   Title:="Куда вставить?", Type:=8)  
On Error GoTo 0  
 
If OutRange Is Nothing Then ' если нажата кнопка "отмена"  
   MsgBox "Действие отменено"  
Else ' Выводим выходной массив в указанное место  
   OutRange.Resize(NoDupes.Count, 1).Value = WorksheetFunction.Transpose(ND)  
End If  
 
End Sub{/post}{/quote}  
 
Есть замечания по коду:  
 
1.ВАЖНО!!! - Ошибка - выгружается на одно значение меньше!!! Последнее пропадает.  
Ошибка тут:  
ReDim ND(NoDupes.Count) 'ļåšåģåłąåģ źīėėåźöčž ā ģąńńčā  
For i = 1 To NoDupes.Count  
   ND(i) = NoDupes.Item(i)  
Next i  
 
2. Если уж перегружаете в массив, то перегружайте в двумерный, чтоб выгружать без Transpose - это позволит работать с большим количеством, и в 2000 Экселе тоже.
 
 
 
#7
21.09.2011 13:34:43
Это я был.  
Повторюсь:  
 
 
Есть замечания по коду:  
 
1.ВАЖНО!!! - Ошибка - выгружается на одно значение меньше!!! Последнее пропадает.  
Ошибка тут:  
 
ReDim ND(NoDupes.Count) 'перемещаем коллекцию в массив  
For i = 1 To NoDupes.Count  
   ND(i) = NoDupes.Item(i)  
Next i  
 
2. Если уж перегружаете в массив, то перегружайте в двумерный, чтоб выгружать без Transpose - это позволит работать с большим количеством, и в 2000 Экселе тоже.
 
 
 
#8
21.09.2011 13:37:53
Мне очень нужна подобная надстройка но у меня какая-то беда с ними в силу моей неграмотности видимо..  
Вот фото того что у меня подключено...  
<EM><STRONG>Файл удален</STRONG> - велик размер - [<STRONG>МОДЕРАТОРЫ</STRONG>]</EM>
 
 
 
#9
21.09.2011 13:39:56
А вот то что у меня отображается на панели..  
 
При этом работают только : Колонтитулы, и Самар дата пикер, да и суммаПрописью    
Как бы мне все это отразить
 
 
 
#10
21.09.2011 13:50:01
{quote}{login=Hugo}{date=21.09.2011 01:34}{thema=}{post}Это я был.  
Повторюсь:  
 
 
Есть замечания по коду:  
 
1.ВАЖНО!!! - Ошибка - выгружается на одно значение меньше!!! Последнее пропадает.  
Ошибка тут:  
 
ReDim ND(NoDupes.Count) 'перемещаем коллекцию в массив  
For i = 1 To NoDupes.Count  
   ND(i) = NoDupes.Item(i)  
Next i  
 
2. Если уж перегружаете в массив, то перегружайте в двумерный, чтоб выгружать без Transpose - это позволит работать с большим количеством, и в 2000 Экселе тоже.{/post}{/quote}  
 
Не согласен - Проверено неоднократно - выгружает точное количество уникальных и по количеству тоже пока нет проблем!
 
 
 
#11
21.09.2011 13:53:37
Так я же не просто так - проверил.  
Вот даже файл ещё открыт - из  
1  
2  
1  
3  
 
выдало    
1  
2
 
 
 
#12
21.09.2011 13:59:19
{quote}{login=Микки}{date=21.09.2011 01:37}{thema=}{post}Мне очень нужна подобная надстройка но у меня какая-то беда с ними в силу моей неграмотности видимо..  
Вот фото того что у меня подключено...{/post}{/quote}  
 
Сделайте свою надстройку, а в неё всё нужное запихните - удобнее чем с личной книгой макросов. А чтоб процедуру вставить в контекстное меню:  
 
Public Sub КонтекстноеМенюЯчейки()  
Dim Km As CommandBarControl  
   Set Km = CommandBars("cell").Controls.Add  
   With Km  
       .Caption = "ВыборУникальныхЗначений" 'модуль  
       .OnAction = "ОтборУникальныхЗначений" 'процедура  
   End With  
End Sub  
Запустите и контектное меню изменится. Чтобы убрать нововведения:  
 
CommandBars("Cell").Reset Восстановление первоначального контекстного меню  
 
У Уокенбаха всё хорошо описано.
 
 
 
#13
21.09.2011 14:01:25
{quote}{login=Hugo}{date=21.09.2011 01:53}{thema=}{post}Так я же не просто так - проверил.  
Вот даже файл ещё открыт - из  
1  
2  
1  
3  
 
выдало    
1  
2{/post}{/quote}  
 
Неправильный у Вас Эксел (пиратский наверно :-))))! У меня в этом примере всё правильно выдал!!!  
1  
2  
3
 
 
 
#14
21.09.2011 14:02:50
Понял, в чём дело - у Вас в начале кода прописана директива  
 
Option Base 1  
 
Без этого будет работать с ошибкой!  
Нужно это публиковать вместе с кодом, а то народ наработает...  
А лучше код исправить, т.к. по умолчанию таких директив ни у кого нет, у меня так нигде не используется.
 
 
 
#15
21.09.2011 14:07:14
{quote}{login=Hugo}{date=21.09.2011 02:02}{thema=}{post}Понял, в чём дело - у Вас в начале кода прописана директива  
 
Option Base 1  
 
Без этого будет работать с ошибкой!  
Нужно это публиковать вместе с кодом, а то народ наработает...  
А лучше код исправить, т.к. по умолчанию таких директив ни у кого нет, у меня так нигде не используется.{/post}{/quote}  
 
Консенсус!  
Option Explicit  
Option Base 1  
У меня только в этом модуле есть эти строки. Видать начитался умных книжек, эксперементировал )))). Сейчас бы и не вспомнил, зачем оно нужно.
 
 
 
#16
21.09.2011 14:13:22
>>у меня так нигде не используется  
Я тож не сторонник. А еще я думаю, что незачем изобретать велосипед  
 
Swap1 = NoDupes(i)  
Swap2 = NoDupes(j)  
NoDupes.Add Swap1, before:=j  
NoDupes.Add Swap2, before:=i  
NoDupes.Remove i + 1  
NoDupes.Remove j + 1  
 
Я бы сделал так  
 
sub io()  
Dim v, i&  
on error resume next  
with new Collection  
For Each v in [A1:C10].value
.add v,cstr(v) ' по желаню суда еще можно добавить удаление пробелов  
next  
redim v(1 to .count, 1 to 1)  
For i = 1 to .Count: v(i,1) = .item(i):next  
end with  
end sub
Чебурашка стал символом олимпийских игр. А чего достиг ты?
Тишина - самый громкий звук

https://github.com/nervgh
 
 
 
#17
21.09.2011 14:45:39
{quote}{login=nerv}{date=21.09.2011 02:13}{thema=}{post}>>у меня так нигде не используется  
Я тож не сторонник. А еще я думаю, что незачем изобретать велосипед  
 
Swap1 = NoDupes(i)  
Swap2 = NoDupes(j)  
NoDupes.Add Swap1, before:=j  
NoDupes.Add Swap2, before:=i  
NoDupes.Remove i + 1  
NoDupes.Remove j + 1  
 
Я бы сделал так  
 
sub io()  
Dim v, i&  
on error resume next  
with new Collection  
For Each v in [A1:C10].value
.add v,cstr(v) ' по желаню суда еще можно добавить удаление пробелов  
next  
redim v(1 to .count, 1 to 1)  
For i = 1 to .Count: v(i,1) = .item(i):next  
end with  
end sub{/post}{/quote}  
 
Так это у меня тремя строками.  
 
For Each cell In InRange    
   NoDupes.Add cell.Value, CStr(cell.Value)  
Next cell  
 
А Swap используется для сортировки отобранного массива. Это велосипед САМОГО Уокенбаха!
 
 
 
#18
21.09.2011 14:48:51
{quote}{login=Микки}{date=21.09.2011 01:37}{thema=}{post}Мне очень нужна подобная надстройка {/post}{/quote}Миша, это уже не смешно. Неужели так трудно посмотреть размер файла перед отправкой? Впредь я буду удалять не только вложение, но и целиком твоё сообщение.
 
 
 
#19
21.09.2011 14:53:24
Чем не устраивает размер файла? У Вас что, интернет не безлимитный?
 
 
 
#20
21.09.2011 15:00:46
>>Так это у меня тремя строками.  
 
For Each cell In InRange  
NoDupes.Add cell.Value, CStr(cell.Value)  
Next cell  
 
Да что Вы говорите! Ну вот возьмите и запустите "свои" три строчки. Работает?)  
 
>>А Swap используется для сортировки отобранного массива.  
Я это понял. Но тема звучала как "уникальные". Про сортировку не слова.  
>>Это велосипед САМОГО Уокенбаха!  
Правда? Не дочитал ^_^  
 
Советую пройти по ссылке, кот. я давал выше и посмотреть последний файл в теме
Чебурашка стал символом олимпийских игр. А чего достиг ты?
Тишина - самый громкий звук

https://github.com/nervgh
 
 
 
#21
21.09.2011 15:03:16
{quote}{login=Серега}{date=21.09.2011 02:53}{thema=}{post}Чем не устраивает размер файла? У Вас что, интернет не безлимитный?{/post}{/quote}Конечно, нет : )
Чебурашка стал символом олимпийских игр. А чего достиг ты?
Тишина - самый громкий звук

https://github.com/nervgh
 
 
 
#22
21.09.2011 15:03:24
{quote}{login=Серега}{date=21.09.2011 02:53}{thema=}{post}Чем не устраивает размер файла? У Вас что, интернет не безлимитный?{/post}{/quote}  
Правила почитайте.
 
 
 
#23
21.09.2011 16:04:30
{quote}{login=Серега}{date=21.09.2011 02:53}{thema=}{post}Чем не устраивает размер файла? У Вас что, интернет не безлимитный?{/post}{/quote}Есть несколько причин, по которым установлено такое ограничение. А у некоторых действительно траффик очень дорогой - Вы не знали, что такое возможно?
 
 
 
Страницы: 1
Читают тему
Наверх
Loading...