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 = avArrEnd SubУниверсальный код выбора уникальных значений
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 = avArrEnd Sub
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 NextEnd Sub
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 + 1Cells(i, 10 + K) = iValue Next Set Uniq = Nothing NextEnd Sub
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 NextEnd Sub