Excel это не сложно
Добро пожаловать, Гость. Пожалуйста, войдите или зарегистрируйтесь.
28.03.2024, 21:32:30

Войти
Добавляйтесь в нашу группу ВКонтакте - будьте в курсе всех новых событий сайта, узнавайте первым обо всех акциях и новых статьях!
33 233 Сообщений в 5 454 Тем от 6 750 Пользователей
Последний пользователь: Alex1210
*
Перейти на сайт Хитрости Надстройка MulTEx Обучающие тренинги Наша группа ВКонтакте
Правила форума Начало Помощь Поиск Календарь Войти Регистрация Выйти
+  Excel это не сложно
|-+  Основные форумы
| |-+  Вопросы по Excel и VBA
| | |-+  Выбор уникальных значений. Нужна помощь.
Страниц: [1]   Вниз
Печать
Автор Тема: Выбор уникальных значений. Нужна помощь.  (Прочитано 6697 раз)
0 Пользователей и 1 Гость смотрят эту тему.
eXtra
Новичок
*

Репутация: +0/-0
Офлайн Офлайн

Сообщений: 4


Просмотр профиля E-mail
« : 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Универсальный код выбора уникальных значений
Записан
eXtra
Новичок
*

Репутация: +0/-0
Офлайн Офлайн

Сообщений: 4


Просмотр профиля E-mail
« Ответ #1 : 11.02.2018, 15:37:11 »

Товарищи, ну помогите, пожалуйста, кому не лень. Сама не понимаю особо в экселе, профиль вообще не мой, а изучать все с нуля ради разовой задачи как-то бессмысленно.
Записан
Дмитрий Щербаков(The_Prist)
Администратор
Ветеран
*****

Репутация: +485/-0
Офлайн Офлайн

Сообщений: 5 828



Просмотр профиля WWW
« Ответ #2 : 11.02.2018, 16:44:27 »

Здесь код вообще не нужен. Здесь достаточно одной формулы:
=ЕСЛИ(СЧЁТЕСЛИ($A$1:A1;A1)=1;A1;"")
Записываете её в ячейку В1 и растягиваете до конца данных столбца А.

P.S. Помощь можно получить быстрее, если прикладывать не картинки, а файлы Excel с данными. Впрочем, в правилах форума это все есть...
Записан

Даже самый простой вопрос можно превратить в огромную проблему. Достаточно не уметь формулировать вопросы...
Пункты приёма Спасибов:    -41001332272872  -R298726502453
eXtra
Новичок
*

Репутация: +0/-0
Офлайн Офлайн

Сообщений: 4


Просмотр профиля E-mail
« Ответ #3 : 11.02.2018, 16:50:03 »

Спасибо за ответ! Только эта формула мне не подходит, т.к. таблица слишком большая, все зависает, я уже замучилась. А тут нашла этот макрос, и он отлично подошел, кроме этого нюанса.
P.S. подумала, что файл слишком примитивный, чтобы его прикладывать. Добавила вложением.
« Последнее редактирование: 11.02.2018, 17:06:04 от eXtra » Записан
Дмитрий Щербаков(The_Prist)
Администратор
Ветеран
*****

Репутация: +485/-0
Офлайн Офлайн

Сообщений: 5 828



Просмотр профиля WWW
« Ответ #4 : 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
Записан

Даже самый простой вопрос можно превратить в огромную проблему. Достаточно не уметь формулировать вопросы...
Пункты приёма Спасибов:    -41001332272872  -R298726502453
eXtra
Новичок
*

Репутация: +0/-0
Офлайн Офлайн

Сообщений: 4


Просмотр профиля E-mail
« Ответ #5 : 11.02.2018, 18:21:32 »

Ох, какая красота! Все работает прекрасно! Большое вам спасибо! Вы лучший!)
Записан
PROFF84
Новичок
*

Репутация: +0/-0
Офлайн Офлайн

Сообщений: 3


Просмотр профиля
« Ответ #6 : 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
То есть нужна уникальность по строке и выводить без пустых ячеек

Надеюсь на вашу помощь.

« Последнее редактирование: 07.08.2018, 12:39:11 от vikttur » Записан
Юрий М
Глобальный модератор
Ветеран
*****

Репутация: +112/-0
Офлайн Офлайн

Сообщений: 2 077



Просмотр профиля E-mail
« Ответ #7 : 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

« Последнее редактирование: 08.08.2018, 23:39:27 от Юрий М » Записан
PROFF84
Новичок
*

Репутация: +0/-0
Офлайн Офлайн

Сообщений: 3


Просмотр профиля
« Ответ #8 : 09.08.2018, 15:20:22 »

Когда же Вы это уясните?..

Скрипт работает, но можно переделать еще, чтобы вывод делал в каждую отдельную ячейку?
Приложил Файл как хотелось бы видеть результат (с примером для тестов)
Записан
PROFF84
Новичок
*

Репутация: +0/-0
Офлайн Офлайн

Сообщений: 3


Просмотр профиля
« Ответ #9 : 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
Записан
Юрий М
Глобальный модератор
Ветеран
*****

Репутация: +112/-0
Офлайн Офлайн

Сообщений: 2 077



Просмотр профиля E-mail
« Ответ #10 : 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
« Последнее редактирование: 09.08.2018, 23:46:11 от Юрий М » Записан
Страниц: [1]   Вверх
Печать
Перейти в:  

Powered by MySQL Powered by PHP Powered by SMF 1.1.21 | SMF © 2006-2011, Simple Machines Valid XHTML 1.0! Valid CSS!
Яндекс.Метрика Рейтинг@Mail.ru