Excel это не сложно

Основные форумы => Вопросы по Excel и VBA => Тема начата: eXtra от 10.02.2018, 23:11:14



Название: Выбор уникальных значений. Нужна помощь.
Отправлено: eXtra от 10.02.2018, 23:11:14
Добрый день!
Подскажите, пожалуйста, с таким вопросом.
Для выбора уников использую макрос (УНИВЕРСАЛЬНЫЙ КОД ВЫБОРА УНИКАЛЬНЫХ ЗНАЧЕНИЙ). Все отлично работает, НО мне нужно, чтобы уники в другом столбце располагались в той же строке, что и родитель.
Собственно, первая картинка - как работает код, вторая - так, как нужно мне.

Сам макрос
Код: (vb)
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
В таком виде этот макрос никак не подойдет. И быстрее формулы вряд ли отработает. Но переделать можно. Например, так:
Код: (vb)
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.
Код: (vb)
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
пока примерно так переделал (еще не окончательный вариант)

Код: (vb)
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
Код: (vb)
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