Поиск  Пользователи  Правила 
Закрыть
Логин:
Пароль:
Забыли свой пароль?
Регистрация
Войти
 
Страницы: 1
RSS
Вывод макросом в одну ячейку всех уникальных значений видимого диапазона
 
Здравствуйте господа. Возникла необходимость найти все уникальные значения в диапазоне и вывести все эти значения в одну ячейку текстовой строкой. Нашел на одном из сайтов небольшой макрос для поиска уникальных значений. Вот тело макроса:

Код
Sub ОтборУникальных()
 
'Объявляем переменные
'myRange - диапазон ячеек, заполненный исходным списком элементов
'myCell - отдельная ячейка диапазона
'myCollection - коллекция
'myElement - элемент коллекции (должен быть типа "Variant")
Dim myRange As Range, myCell As Range, myCollection As New Collection, _
myElement As Variant, i As Long
 
'присваиваем переменной myRange диапазон ячеек с исходным списком элементов
Set myRange = Range("B2:B29")
 
'заполняем новую коллекцию уникальными элементами
On Error Resume Next
For Each myCell In myRange
myCollection.Add CStr(myCell.Value), CStr(myCell.Value)
Next myCell
On Error GoTo 0 

На этом же листе в ячейку A1 требуется вписать строковое выражение - что-то по типу
Range ("A1"). Value = "Найдены следующие договоры:" &"№"& myElement "," + 1
То есть требуется из коллекции myCollection взять (перебрать) все уникальные значения myElement и поместить их в текстовую строку в ячейку A1 по шаблону указанному выше.
Прошу оказать посильную помощь в доработке макроса.
 
Цитата
Excelman написал:
"Найдены следующие договоры:" &"№"& myElement "," + 1
а +1 - это подразумевается, следующий элемент?
 
yozhik, да верно. То есть, № myElement1,  № myElement2, № myElement3 и т.д.
Изменено: Excelman - 16 Май 2018 18:12:56
 
через словарь
Код
Sub dc()
Dim dic, myRange As Range, myCell As Range, msg As String
Set dic = CreateObject("Scripting.Dictionary")
Set myRange = Range("B2:B29")
For Each myCell In myRange
    If Not dic.Exists(myCell.Value) Then
        If Len(msg) = 0 Then msg = "№" & myCell.Value Else msg = msg & ",№" & myCell.Value
        v = dic.Item(myCell.Value)
    End If
Next myCell
[a1] = "Найдены следующие договоры: " & msg
End Sub
 
yozhik, Все именно так как надо!!! Спасибо Вам большое! Но чуть не забыл маленький нюанс. Дело в том что на листе у меня автофильтр. Подскажите пожалуйста как
нужно изменить строку Set myRange = Range("B2:B29"), чтобы в этом диапазоне перебирались только видимые ячейки?

На самом деле диапазон по столбцу "B"  в 1000 строк, но часть значений скрыто фильтром, т.к. они (скрытые значения) не нужны для вывода в ячейке А1., нужны только видимые.
Изменено: Excelman - 16 Май 2018 18:27:45
 
Цитата
Excelman написал:
как изменить строку Set myRange = Range("B2:B29"), чтобы в этом диапазоне перебирались только видимые ячейки?
Я не знаю как ее изменить, может просто добавить кое-что до и после кода из #4 от yozhik?
 
Так ведь просто изменить - дописать
Код
.SpecialCells(xlCellTypeVisible)

А результирующую строку можно собирать и в коде на коллекции - если добавилось в коллекцию - собираем, если ошибка - пропускаем. Но на словаре код попроще, нет возни с ошибками.
Изменено: Hugo - 16 Май 2018 23:15:04
 
Hugo, спасибо. Именно  SpecialCells я и подразумевал. То есть синтаксис будет такой ?
Код
Set myRange = Range("B2:B29").SpecialCells(xlCellTypeVisible)

Только что проверил. Да работает. То есть ищет уникальные значения только в видимом диапазоне.

Изменено: Excelman - 17 Май 2018 07:22:00
 
yozhik, как уже говорил Ваше решение в основном работает отлично, но выявился малюсенький изъян. Он не критичный, но все-же. Оказалось, что если в столбце "B" попадется пустая ячейка (то есть Empty), то результат будет -> Найдены следующие договоры: №, если в диапазоне попадется ячейка со значением "0", то результат -> Найдены следующие договоры: №0. Если Вас (или кого из форумчан) не затруднит, пожалуйста дополните макрос на условия что бы в результат не попадали значения "0" и "Пусто" (Empty).
Повторюсь, это не критично, но так как текстовый результат будет выводится в определенную форму то смотрится немного корявенько. Вот пример для наглядности

Найдены следующие договоры: №14504/ФД-87, №, №0    
Изменено: Excelman - 17 Май 2018 07:50:26
 
Excelman,так Вы сами сможете) сделать в цикле проверку значения myCell. Если значение не равно нулю, то выполнять всё что в цикле
Изменено: yozhik - 17 Май 2018 10:50:12
 
yozhik написал:
Цитата
Excelman ,так Вы сами сможете) сделать в цикле проверку
Спасибо, что верите в мои силы, в которых я сам не уверен))).:)
Страницы: 1
Читают тему (гостей: 1)