Название: Выбор уникальных значений. Нужна помощь.
Отправлено: eXtra от 10.02.2018, 23:11:14
Добрый день! Подскажите, пожалуйста, с таким вопросом. Для выбора уников использую макрос (УНИВЕРСАЛЬНЫЙ КОД ВЫБОРА УНИКАЛЬНЫХ ЗНАЧЕНИЙ). Все отлично работает, НО мне нужно, чтобы уники в другом столбце располагались в той же строке, что и родитель. Собственно, первая картинка - как работает код, вторая - так, как нужно мне. Сам макрос Sub Extract_Unique() Dim x, avArr, li As Long Dim avVals Dim rVals As Range, rResultCell As Range On Error Resume Next 'запрашиваем адрес ячеек для выбора уникальных значений Set rVals = Application.InputBox("Укажите диапазон ячеек для выборки уникальных значений", "Запрос данных", "A2:A51", Type:=8) If rVals Is Nothing Then 'если нажата кнопка Отмена Exit Sub End If 'если указана только одна ячейка - нет смысла выбирать If rVals.Count = 1 Then MsgBox "Для отбора уникальных значений требуется указать более одной ячейки", vbInformation, "www.excel-vba.ru" Exit Sub End If 'отсекаем пустые строки и столбцы вне рабочего диапазона Set rVals = Intersect(rVals, rVals.Parent.UsedRange) 'если указаны только пустые ячейки вне рабочего диапазона If rVals Is Nothing Then MsgBox "Недостаточно данных для выбора значений", vbInformation, "www.excel-vba.ru" Exit Sub End If avVals = rVals.Value 'запрашиваем ячейку для вывода результата Set rResultCell = Application.InputBox("Укажите ячейку для вставки отобранных уникальных значений", "Запрос данных", "E2", Type:=8) If rResultCell Is Nothing Then 'если нажата кнопка Отмена Exit Sub End If 'определяем максимально возможную размерность массива для результата ReDim avArr(1 To Rows.Count, 1 To 1) 'при помощи объекта Коллекции(Collection) 'отбираем только уникальные записи, 'т.к. Коллекции не могут содержать повторяющиеся значения With New Collection On Error Resume Next For Each x In avVals If Len(CStr(x)) Then 'пропускаем пустые ячейки .Add x, CStr(x) 'если добавляемый элемент уже есть в Коллекции - возникнет ошибка 'если же ошибки нет - такое значение еще не внесено, 'добавляем в результирующий массив If Err = 0 Then li = li + 1 avArr(li, 1) = x Else 'обязательно очищаем объект Ошибки Err.Clear End If End If Next End With 'записываем результат на лист, начиная с указанной ячейки If li Then rResultCell.Cells(1, 1).Resize(li).Value = avArr End SubУниверсальный код выбора уникальных значений
Название: Re:Выбор уникальных значений. Нужна помощь.
Отправлено: eXtra от 11.02.2018, 15:37:11
Товарищи, ну помогите, пожалуйста, кому не лень. Сама не понимаю особо в экселе, профиль вообще не мой, а изучать все с нуля ради разовой задачи как-то бессмысленно.
Название: Re:Выбор уникальных значений. Нужна помощь.
Отправлено: Дмитрий Щербаков(The_Prist) от 11.02.2018, 16:44:27
Здесь код вообще не нужен. Здесь достаточно одной формулы: =ЕСЛИ(СЧЁТЕСЛИ($A$1:A1;A1)=1;A1;"") Записываете её в ячейку В1 и растягиваете до конца данных столбца А.
P.S. Помощь можно получить быстрее, если прикладывать не картинки, а файлы Excel с данными. Впрочем, в правилах форума это все есть...
Название: Re:Выбор уникальных значений. Нужна помощь.
Отправлено: eXtra от 11.02.2018, 16:50:03
Спасибо за ответ! Только эта формула мне не подходит, т.к. таблица слишком большая, все зависает, я уже замучилась. А тут нашла этот макрос, и он отлично подошел, кроме этого нюанса. P.S. подумала, что файл слишком примитивный, чтобы его прикладывать. Добавила вложением.
Название: Re:Выбор уникальных значений. Нужна помощь.
Отправлено: Дмитрий Щербаков(The_Prist) от 11.02.2018, 18:15:56
В таком виде этот макрос никак не подойдет. И быстрее формулы вряд ли отработает. Но переделать можно. Например, так: Sub Extract_Unique() Dim x, avArr, lr As Long, lc As Long Dim avVals Dim rVals As Range, rResultCell As Range Dim IsFill As Boolean On Error Resume Next 'запрашиваем адрес ячеек для выбора уникальных значений Set rVals = Application.InputBox("Укажите диапазон ячеек для выборки уникальных значений", "Запрос данных", "A1:A51", Type:=8) If rVals Is Nothing Then 'если нажата кнопка Отмена Exit Sub End If 'если указана только одна ячейка - нет смысла выбирать If rVals.Count = 1 Then MsgBox "Для отбора уникальных значений требуется указать более одной ячейки", vbInformation, "www.excel-vba.ru" Exit Sub End If 'отсекаем пустые строки и столбцы вне рабочего диапазона Set rVals = Intersect(rVals, rVals.Parent.UsedRange) 'если указаны только пустые ячейки вне рабочего диапазона If rVals Is Nothing Then MsgBox "Недостаточно данных для выбора значений", vbInformation, "www.excel-vba.ru" Exit Sub End If avVals = rVals.Value 'запрашиваем ячейку для вывода результата Set rResultCell = Application.InputBox("Укажите ячейку для вставки отобранных уникальных значений", "Запрос данных", "B1", Type:=8) If rResultCell Is Nothing Then 'если нажата кнопка Отмена Exit Sub End If 'определяем максимально возможную размерность массива для результата ReDim avArr(1 To UBound(avVals, 1), 1 To UBound(avVals, 2)) 'при помощи объекта Коллекции(Collection) 'отбираем только уникальные записи, 'т.к. Коллекции не могут содержать повторяющиеся значения With New Collection On Error Resume Next For lr = 1 To UBound(avVals, 1) For lc = 1 To UBound(avVals, 2) x = avVals(lr, lc) If Len(CStr(x)) Then 'пропускаем пустые ячейки .Add x, CStr(x) 'если добавляемый элемент уже есть в Коллекции - возникнет ошибка 'если же ошибки нет - такое значение еще не внесено, 'добавляем в результирующий массив If Err = 0 Then IsFill = True avArr(lr, lc) = x Else 'обязательно очищаем объект Ошибки Err.Clear End If End If Next Next End With 'записываем результат на лист, начиная с указанной ячейки If IsFill Then rResultCell.Resize(UBound(avVals, 1), UBound(avVals, 2)).Value = avArr End Sub
Название: Re:Выбор уникальных значений. Нужна помощь.
Отправлено: eXtra от 11.02.2018, 18:21:32
Ох, какая красота! Все работает прекрасно! Большое вам спасибо! Вы лучший!)
Название: Re:Выбор уникальных значений. Нужна помощь.
Отправлено: PROFF84 от 07.08.2018, 11:04:26
Дмитрий Щербаков, можно ли дополнить Ваш код так (а может и другой предложить), чтобы он делал проверку на уникальность в строчках, а не по всему массиву и делал сдвиг влево, если имеются пустые ячейки в строке. Пример сейчас выводит так: ДАНО: 111 222 222 333 111 222 333 111 555 666 777 777 333 888 888
Данный скрипт работает так: 111 222 333 555 666 777 888
А хотелось бы выводить так: 111 222 333 222 333 111 555 666 777 333 888 То есть нужна уникальность по строке и выводить без пустых ячеек
Надеюсь на вашу помощь.
Название: Re:Выбор уникальных значений. Нужна помощь.
Отправлено: Юрий М от 08.08.2018, 23:36:12
Помощь можно получить быстрее, если прикладывать не картинки, а файлы Excel с данными. Впрочем, в правилах форума это все есть... Когда же Вы это уясните?.. См. вариант: исходные данные У МЕНЯ начинаются в ячейке А2. Sub Macro1() Dim LastRow As Long, LastColumn As Long, i As Long, j As Long, Uniq As New Collection, iValue LastRow = Cells(Rows.Count, 1).End(xlUp).Row For i = 2 To LastRow LastColumn = Cells(i, Columns.Count).End(xlToLeft).Column For j = 1 To LastColumn On Error Resume Next If Cells(i, j) <> "" Then Uniq.Add Cells(i, j), CStr(Cells(i, j)) Next For Each iValue In Uniq If Cells(i, 10) = "" Then Cells(i, 10) = iValue Else Cells(i, 10) = Cells(i, 10) & " " & iValue End If Next Set Uniq = Nothing Next End Sub
Название: Re:Выбор уникальных значений. Нужна помощь.
Отправлено: PROFF84 от 09.08.2018, 15:20:22
Когда же Вы это уясните?..
Скрипт работает, но можно переделать еще, чтобы вывод делал в каждую отдельную ячейку? Приложил Файл как хотелось бы видеть результат (с примером для тестов)
Название: Re:Выбор уникальных значений. Нужна помощь.
Отправлено: PROFF84 от 09.08.2018, 16:30:14
пока примерно так переделал (еще не окончательный вариант) Sub Macro12222222222222() Dim LastRow As Long, LastColumn As Long, i As Long, j As Long, Uniq As New Collection, iValue LastRow = Cells(Rows.Count, 1).End(xlUp).row For i = 1 To LastRow 'с 1-й строки начинаем поиск K = 0 'Cells(i, 10 + K) = "" LastColumn = Cells(i, Columns.Count).End(xlToLeft).Column For j = 1 To LastColumn On Error Resume Next If Cells(i, j) <> "" Then Uniq.Add Cells(i, j), CStr(Cells(i, j)) Next For Each iValue In Uniq K = K + 1 Cells(i, 10 + K) = iValue Next Set Uniq = Nothing Next End Sub
Название: Re:Выбор уникальных значений. Нужна помощь.
Отправлено: Юрий М от 09.08.2018, 23:42:10
Sub Macro1() Dim LastRow As Long, LastColumn As Long, i As Long, j As Long, Uniq As New Collection, iValue, FreeColumn As Long LastRow = Cells(Rows.Count, 1).End(xlUp).Row For i = 2 To LastRow LastColumn = Cells(i, 9).End(xlToLeft).Column For j = 1 To LastColumn On Error Resume Next If Cells(i, j) <> "" Then Uniq.Add Cells(i, j), CStr(Cells(i, j)) Next FreeColumn = 10 For Each iValue In Uniq Cells(i, FreeColumn) = iValue FreeColumn = FreeColumn + 1 Next Set Uniq = Nothing FreeColumn = 10 Next End Sub
|