КАК ПОЛУЧИТЬ СПИСОК УНИКАЛЬНЫХ(НЕ ПОВТОРЯЮЩИХСЯ) ЗНАЧЕНИЙ?

[Tow]

Здравствуйте, пытаюсь применить для себя Ваш макрос изменив "A2:A51" на "C2:C51", но почему то при запросе данных выдает диапазон "$A:$AY"?, а если другие столбцы то работает. Что делаю не так?

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

[Дмитрий Щербаков(The_Prist)]

А где Вы что вообще изменили? В коде не вижу никаких изменений.

[Tow]

Код (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("Укажите диапазон ячеек для выборки уникальных значений", "Запрос данных", "C2:C51", 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("Укажите ячейку для вставки отобранных уникальных значений", "Запрос данных", "A2", 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
[admin]Коды оформляйте тегами VBCode. п.п. 4.25 Правил форума[/admin]

[Дмитрий Щербаков(The_Prist)]

Попробуйте указать в стиле R1C1:

Код (vb) Выделить Развернуть

Set rVals = Application.InputBox("Укажите диапазон ячеек для выборки уникальных значений", "Запрос данных", "R2C3:R51C3", Type:=8)
или так:

Код (vb) Выделить Развернуть

Set rVals = Application.InputBox("Укажите диапазон ячеек для выборки уникальных значений", "Запрос данных", Range("C2:C51").Address(1, 1), Type:=8)

P.S. Коды оформляйте тегами VBCode. п.п. 4.25 Правил форума

[Tow]

Спасибо большое!!!

[Дмитрий Щербаков(The_Prist)]

А зачем Вы файл приложили? Что-то все еще не получается или проблема решена?

[Tow]

Да нет я разобрался, просто пользователь parovoz, очень сильно просил , чтобы я его выложил .