======================================================= Функция (UDF) "ЭЛЕМЕНТ_СПИСКА" ======================================================= Данная Определенная пользователем функция (User-Defined Function или UDF) возвращает в ячейку листа, куда она введена, N-ное из уникальных значений в указанном диапазоне: [vba]
Код
Function ЭЛЕМЕНТ_СПИСКА(Диапазон As Range, Номер_элемента As Integer) '--------------------------------------------------------------------------------------- ' Procedure : ЭЛЕМЕНТ_СПИСКА ' Author : Alex_ST & The_Prist & Лузер™ ' Topic_HEADER : Функция СЧЁТ_РАЗНЫХ (UDF) ' Topic_URL : http://www.planetaexcel.ru/forum.php?thread_id=15009&useraction=login ' Post_Author : ' Post_URL : '--------------------------------------------------------------------------------------- Dim TmpArr(), iArr TmpArr = Intersect(Диапазон.Parent.UsedRange, Диапазон).Value Set Диапазон = Intersect(Диапазон.Parent.UsedRange, Диапазон) On Error Resume Next With New Collection For Each iArr In TmpArr If iArr <> "" Then .Add Trim(iArr), Trim(CStr(iArr)) Next If Номер_элемента >= 1 And Номер_элемента <= .Count Then ЭЛЕМЕНТ_СПИСКА = .Item(Номер_элемента) Else ЭЛЕМЕНТ_СПИСКА = "#Н/Д" End If End With End Function
[/vba]
Примечания: 1. Производить предварительную "зачистку" диапазона от лидирующих и финиширующих пробелов нет необходимости, т.к. они в UDF и так игнорируются. 2. Если необходимо очищать не только от лидирующих и финиширующих пробелов, но также и от множественных пробелов внутри стринга, то вместо строки [vba]
Код
If iArr <> "" Then .Add iArr, Trim(iArr)
[/vba]
можно написать: [vba]
Код
If iArr <> "" Then .Add iArr, Application.Trim(iArr)
[/vba]
или (если не будет работать): [vba]
Код
If iArr <> "" Then .Add iArr, Application.WorksheetFunction.Trim(iArr)
[/vba]
НО в таком случае возможны "тормоза" 3. Для ускорения работы указанный в аргументе функции Диапазон ограничивается до UsedRange. Поэтому можно указывать целиком столбец, не опасаясь больших "тормозов".
======================================================= Функция (UDF) "ЭЛЕМЕНТ_СПИСКА" ======================================================= Данная Определенная пользователем функция (User-Defined Function или UDF) возвращает в ячейку листа, куда она введена, N-ное из уникальных значений в указанном диапазоне: [vba]
Код
Function ЭЛЕМЕНТ_СПИСКА(Диапазон As Range, Номер_элемента As Integer) '--------------------------------------------------------------------------------------- ' Procedure : ЭЛЕМЕНТ_СПИСКА ' Author : Alex_ST & The_Prist & Лузер™ ' Topic_HEADER : Функция СЧЁТ_РАЗНЫХ (UDF) ' Topic_URL : http://www.planetaexcel.ru/forum.php?thread_id=15009&useraction=login ' Post_Author : ' Post_URL : '--------------------------------------------------------------------------------------- Dim TmpArr(), iArr TmpArr = Intersect(Диапазон.Parent.UsedRange, Диапазон).Value Set Диапазон = Intersect(Диапазон.Parent.UsedRange, Диапазон) On Error Resume Next With New Collection For Each iArr In TmpArr If iArr <> "" Then .Add Trim(iArr), Trim(CStr(iArr)) Next If Номер_элемента >= 1 And Номер_элемента <= .Count Then ЭЛЕМЕНТ_СПИСКА = .Item(Номер_элемента) Else ЭЛЕМЕНТ_СПИСКА = "#Н/Д" End If End With End Function
[/vba]
Примечания: 1. Производить предварительную "зачистку" диапазона от лидирующих и финиширующих пробелов нет необходимости, т.к. они в UDF и так игнорируются. 2. Если необходимо очищать не только от лидирующих и финиширующих пробелов, но также и от множественных пробелов внутри стринга, то вместо строки [vba]
Код
If iArr <> "" Then .Add iArr, Trim(iArr)
[/vba]
можно написать: [vba]
Код
If iArr <> "" Then .Add iArr, Application.Trim(iArr)
[/vba]
или (если не будет работать): [vba]
Код
If iArr <> "" Then .Add iArr, Application.WorksheetFunction.Trim(iArr)
[/vba]
НО в таком случае возможны "тормоза" 3. Для ускорения работы указанный в аргументе функции Диапазон ограничивается до UsedRange. Поэтому можно указывать целиком столбец, не опасаясь больших "тормозов".Alex_ST
Используя словари (Dictionary), эту UDF можно ещё больше упростить так: [vba]
Код
Function УНИКАЛЬНЫЙ_ЭЛЕМЕНТ(Диапазон As Range, Номер_элемента As Integer) '--------------------------------------------------------------------------------------- ' Procedure : УНИКАЛЬНЫЙ_ЭЛЕМЕНТ ' Author : Alex_ST ' Purpose : возвращает 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)) 'попытка чтения значения по отсутствующему ключу добавит ключ в словарь Next Arr = .Keys ' массив ключей крпируем в массив If Номер_элемента >= 1 And Номер_элемента <= .Count Then УНИКАЛЬНЫЙ_ЭЛЕМЕНТ = Arr(Номер_элемента - 1) Else УНИКАЛЬНЫЙ_ЭЛЕМЕНТ = "#Н/Д" End If End With End Function
[/vba]
Используя словари (Dictionary), эту UDF можно ещё больше упростить так: [vba]
Код
Function УНИКАЛЬНЫЙ_ЭЛЕМЕНТ(Диапазон As Range, Номер_элемента As Integer) '--------------------------------------------------------------------------------------- ' Procedure : УНИКАЛЬНЫЙ_ЭЛЕМЕНТ ' Author : Alex_ST ' Purpose : возвращает 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)) 'попытка чтения значения по отсутствующему ключу добавит ключ в словарь Next Arr = .Keys ' массив ключей крпируем в массив If Номер_элемента >= 1 And Номер_элемента <= .Count Then УНИКАЛЬНЫЙ_ЭЛЕМЕНТ = Arr(Номер_элемента - 1) Else УНИКАЛЬНЫЙ_ЭЛЕМЕНТ = "#Н/Д" End If End With End Function