Страницы: 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.05.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.05.2018 18:27:45
 
Цитата
Excelman написал:
как изменить строку Set myRange = Range("B2:B29"), чтобы в этом диапазоне перебирались только видимые ячейки?
Я не знаю как ее изменить, может просто добавить кое-что до и после кода из #4 от yozhik?
 
Так ведь просто изменить - дописать
Код
.SpecialCells(xlCellTypeVisible)

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

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

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

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

Excelman, добрый день! Всё таки помогите ответить на этот вопрос, тоже очень он интересует...
Код
Sub dc()Dim dic, myRange As Range, myCell As Range, msg As String
Set dic = CreateObject("Scripting.Dictionary")
Set myRange = Range("B2:B29").SpecialCells(xlCellTypeVisible)
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
Что нужно сюда добавить, чтобы в конечном результате не учитывались 0 или пустые значения?
Изменено: DARR - 01.07.2019 12:17:51
 
Цитата
DARR написал: не учитывались 0 И пустые значения
Код
Sub dc()
Dim dic, myRange As Range, myCell As Range, msg As String
Set dic = CreateObject("Scripting.Dictionary")
Set myRange = Range("B2:B29").SpecialCells(xlCellTypeVisible)
For Each myCell In myRange
    If Not dic.Exists(myCell.Value) Then
        If Not IsEmpty(dic.Item(myCell.Value)) And dic.Item(myCell.Value) <> 0 Then
            If Len(msg) = 0 Then msg = "№" & myCell.Value Else msg = msg & ",№" & myCell.Value
            v = dic.Item(myCell.Value)
        End If
    End If
Next myCell
[a1] = "Найдены следующие договоры: " & msg
End Sub
Согласие есть продукт при полном непротивлении сторон
 
Sanja, к сожалению не работает(
Изменено: DARR - 01.07.2019 15:54:19
 
Не верю
Согласие есть продукт при полном непротивлении сторон
 
Код
If dic.Item(myCell.Value) <> "" And dic.Item(myCell.Value) <> 0 Then
Согласие есть продукт при полном непротивлении сторон
 
В результате у меня получается пустая ячейка. В обоих случаях
 
Я очень за Вас рад.
Без Вашего проблемного файла сказать больше ничего не могу
Согласие есть продукт при полном непротивлении сторон
 
Нужно, чтобы в ячейке B3 было: УК-1, УК-2
 
Код
Sub dc()
Dim dic As Object
Dim myRange As Range, myCell As Range
Set dic = CreateObject("Scripting.Dictionary")
Set myRange = Range("V5:V30").SpecialCells(xlCellTypeVisible)
For Each myCell In myRange
    If Not IsEmpty(myCell) Then
        If Not dic.Exists(myCell.Value) Then
            dic.Add myCell.Value, Empty
        End If
    End If
Next myCell
Range("B3") = Join(dic.Keys, ", ")
End Sub
Согласие есть продукт при полном непротивлении сторон
 
Код
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("V5:V30").SpecialCells(xlCellTypeVisible)
  
'заполняем новую коллекцию уникальными элементами
On Error Resume Next
For Each myCell In myRange
If Len(myCell) Then
myCollection.Add CStr(myCell.Value), CStr(myCell.Value)
If Err.Number = 0 Then s = s & ", №" & myCell.Value
Err.Clear
End If
Next myCell
s = Mid(s, 3)
On Error GoTo 0
Range("A1").Value = "Найдены следующие договоры:" & s
End Sub
 
Sanja, RAN, спасибо большое Вам за помощь, оба варианта работают отлично!
Страницы: 1
Наверх