Страницы: 1
RSS
Извлечение уникальных значений из диапазона
 
Добрый вечер!

Есть таблица D2:AG20 (в примере) из нее нужно выбрать уникальные значения  отдельным перечнем.
В реальности в таблице 365 дней и на 5 тыс человек..... а уникальных значений ...... пока не далось извлечь все.... каждый раз находятся новые уникумы.... :( ..

С уважением, Вера.
 
Есть вот такая UDF: http://prntscr.com/wnpbyi
Код
Function ВЫВОД_УНИКАЛЬНЫХ(Диапазон As Range, Номер_результата As Integer)
'возвращает N-ное из уникальных значений в указанном диапазоне
    Dim iArr, arr(): arr = Intersect(Диапазон, Диапазон.Parent.UsedRange.Cells.SpecialCells(xlCellTypeVisible)).Value
    With CreateObject("Scripting.Dictionary")
        .comparemode = vbTextCompare   ' Создаем словарь
        For Each iArr In arr
            If Trim(iArr) <> "" Then iArr = .Item(Trim(iArr))   'попытка чтения значения по отсутствующему ключу добавит ключ в словарь ( см., например, http://program.rin.ru/cgi-bin/print.pl?id=120#17 )
        Next
        arr = .Keys   ' массив ключей копируем в массив (напрямую читать из .Keys не получается, т.к. словарь определён не явно)
        If Номер_результата >= 1 And Номер_результата <= .Count Then
            ВЫВОД_УНИКАЛЬНЫХ = arr(Номер_результата - 1)
        Else
            ВЫВОД_УНИКАЛЬНЫХ = CVErr(xlErrNA)
        End If
    End With
End Function
Изменено: Hugo - 14.01.2021 23:30:25
 
Ещё как вариант, см. файл
 
Нашел этот макрос на этом форуме.
Код
Option Explicit
Sub TestUniques()
        Dim c As Range
        Dim ar As Variant, var As Variant
        With Sheet1.Range("D2:AG20")
                With CreateObject("Scripting.Dictionary")
                        For Each c In Range("D2:AG20")
                            If Application.WorksheetFunction.IsText(c) Then
                                var = .Item(c.Value)
                            End If
                        Next
                            ar = .Keys
                End With
        End With        
       Sheet1.Range("AJ2").Resize(UBound(ar) + 1) = Application.Transpose(ar) '--->Change destination cell (B12) to suit.       
End Sub

Кстати, интересно было бы увидеть формульный вариант.
Изменено: memo - 15.01.2021 00:04:52
 
А просто удалить дубликаты не судьба? Данные --> Работа с данными --> Удалить дубликаты
Или можно посмотреть ЗДЕСЬ или ТУТ
Изменено: msi2102 - 15.01.2021 09:10:59
 
Цитата
memo написал:
Кстати, интересно было бы увидеть формульный вариант.
согласен)
только кажется будет тормозить)
и еще вариант (3 млн. ячеек 6 сек. вроде подойдет Вам) - диапазон свой задайте только
Код
Sub mrshkei()
a = Timer
Dim arr, i As Long, j As Long, col As New Collection
arr = Range("D2:AG99999")
For i = LBound(arr) To UBound(arr)
    For j = LBound(arr) To UBound(arr, 2) - LBound(arr, 2) + 1
        On Error Resume Next
        col.Add arr(i, j), CStr(arr(i, j))
    Next j
Next i
ReDim arr(1 To col.Count, 1 To 1)
For i = 1 To col.Count
    arr(i, 1) = col(i)
Next i
Range("AI2").Resize(UBound(arr), 1) = arr
Debug.Print Timer - a
End Sub
Изменено: Mershik - 15.01.2021 11:58:19
Не бойтесь совершенства. Вам его не достичь.
 
Доброе время суток.
Версия на Power Query.
 
Если быстро и "в лоб":
Находим координаты уникального знаения (можно в именах разместить): строку (целое) и столбец (после запятой). Из этого "кода" получаем значение:
=ИНДЕКС($A$1:$AG$20;
    МАКС(ЕСЛИ(СЧЁТЕСЛИ($AI$1:AI1;$D$2:$AG$20)=0;СТРОКА($D$2:$AG$20)+СТОЛБЕЦ($D$2:$AG$20)/1000));
    ПРАВБ(ТЕКСТ(
               МАКС(ЕСЛИ(СЧЁТЕСЛИ($AI$1:AI1;$D$2:$AG$20)=0;СТРОКА($D$2:$AG$20)+СТОЛБЕЦ($D$2:$AG$20)/1000));
                          "0,000");3))

Формула массива
 
Цитата
_Bepa_ написал: В реальности в таблице 365 дней и на 5 тыс человек
+
Цитата
vikttur написал: Если быстро и "в лоб":
получим медленно и по ...  :D
По вопросам из тем форума, личку не читаю.
 
БМВ,  :D  
Не бойтесь совершенства. Вам его не достичь.
 
Э, я о скорости писанины информировал, а не о серпах :)
Народ жаждел увидеть формулу. Это как в музее: лежит соха, но пользоваться ею нельзя )
 
Цитата
vikttur написал:
лежит соха, но пользоваться ею нельзя )
Это для тех у кого нет участка на 5000 гектар, тут вполне можно обойтись и без механизации :)
Изменено: memo - 15.01.2021 13:14:32
 
Off
Цитата
memo написал:
тут вполне можно обойтись и без механизации
сейчас стало нельзя. свободные  таджики и узбеки, которые брались за это, нарасхват.
По вопросам из тем форума, личку не читаю.
 
OFF
Цитата
БМВ написал:
таджики и узбеки, которые брались за это, нарасхват
Прогресс беспощаден ко всем без исключения))
Страницы: 1
Наверх