Домашняя страница Undo Do New Save Карта сайта Обратная связь Поиск по форуму
МИР MS EXCEL - Гость.xls

Вход

Регистрация

Напомнить пароль

 

= Мир MS Excel/Функция (UDF) "СЧЁТ_РАЗНЫХ" - Мир MS Excel

Старая форма входа
  • Страница 1 из 1
  • 1
Модератор форума: _Boroda_, китин  
Мир MS Excel » Вопросы и решения » Готовые решения » Функция (UDF) "СЧЁТ_РАЗНЫХ" (Возвращает число уникальных значений в диапазоне)
Функция (UDF) "СЧЁТ_РАЗНЫХ"
Alex_ST Дата: Четверг, 26.08.2010, 10:30 | Сообщение № 1
Группа: Друзья
Ранг: Участник клуба
Сообщений: 3198
Репутация: 606 ±
Замечаний: 0% ±

2003
=======================================================
Функция (UDF) "СЧЁТ_РАЗНЫХ"
=======================================================
Данная Определенная пользователем функция (User-Defined Function или UDF) возвращает в ячейку листа, куда она введена, число уникальных значений в указанном диапазоне:
[vba]
Код
Function СЧЁТ_РАЗНЫХ(Диапазон As Range) As Long
      '---------------------------------------------------------------------------------------
      ' Procedure       : СЧЁТ_РАЗНЫХ
      ' Author            : Alex_ST
      ' Topic_HEADER : Подсчет количества уникальных значений в массиве
      ' Topic_URL       : http://www.planetaexcel.ru/forum.php?thread_id=16844
      ' Post_Author     :
      ' Post_URL         : http://www.planetaexcel.ru/docs/forum_upload/post_131800.zip
      '---------------------------------------------------------------------------------------
      Dim TmpArr(), iArr
      TmpArr = Intersect(Диапазон.Parent.UsedRange, Диапазон).Value
      On Error Resume Next
      With New Collection
         For Each iArr In TmpArr
            If iArr <> "" Then .Add iArr, Trim(iArr)
         Next
         СЧЁТ_РАЗНЫХ = .Count
      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. Поэтому можно указывать целиком столбец, не опасаясь больших "тормозов".
4. Возможно было бы и более очевидное решение - перебор в цикле не элементов массива, а значений ячеек:
[vba]
Код
With New Collection
         For Each iCell In Диапазон
            If iCell.Value <> "" Then .Add iCell.Value, Trim(iCell.Value)
         Next
         СЧЁТ_РАЗНЫХ_0 = .Count
      End With
[/vba]
Но применение предварительного копирования из диапазона в массив ускоряет работу почти в 5 раз!



С уважением,
Алексей
MS Excel 2003 - the best!!!


Сообщение отредактировал Alex_ST - Четверг, 26.08.2010, 20:56
 
Ответить
Сообщение=======================================================
Функция (UDF) "СЧЁТ_РАЗНЫХ"
=======================================================
Данная Определенная пользователем функция (User-Defined Function или UDF) возвращает в ячейку листа, куда она введена, число уникальных значений в указанном диапазоне:
[vba]
Код
Function СЧЁТ_РАЗНЫХ(Диапазон As Range) As Long
      '---------------------------------------------------------------------------------------
      ' Procedure       : СЧЁТ_РАЗНЫХ
      ' Author            : Alex_ST
      ' Topic_HEADER : Подсчет количества уникальных значений в массиве
      ' Topic_URL       : http://www.planetaexcel.ru/forum.php?thread_id=16844
      ' Post_Author     :
      ' Post_URL         : http://www.planetaexcel.ru/docs/forum_upload/post_131800.zip
      '---------------------------------------------------------------------------------------
      Dim TmpArr(), iArr
      TmpArr = Intersect(Диапазон.Parent.UsedRange, Диапазон).Value
      On Error Resume Next
      With New Collection
         For Each iArr In TmpArr
            If iArr <> "" Then .Add iArr, Trim(iArr)
         Next
         СЧЁТ_РАЗНЫХ = .Count
      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. Поэтому можно указывать целиком столбец, не опасаясь больших "тормозов".
4. Возможно было бы и более очевидное решение - перебор в цикле не элементов массива, а значений ячеек:
[vba]
Код
With New Collection
         For Each iCell In Диапазон
            If iCell.Value <> "" Then .Add iCell.Value, Trim(iCell.Value)
         Next
         СЧЁТ_РАЗНЫХ_0 = .Count
      End With
[/vba]
Но применение предварительного копирования из диапазона в массив ускоряет работу почти в 5 раз!

Автор - Alex_ST
Дата добавления - 26.08.2010 в 10:30
Alex_ST Дата: Понедельник, 04.10.2010, 21:35 | Сообщение № 2
Группа: Друзья
Ранг: Участник клуба
Сообщений: 3198
Репутация: 606 ±
Замечаний: 0% ±

2003
Используя словари (Dictionary), эту UDF можно ещё больше упростить так:
[vba]
Код
Function СЧЁТ_РАЗНЫХ(Диапазон As Range) As Long
     '---------------------------------------------------------------------------------------
     ' Procedure    : СЧЁТ_РАЗНЫХ
     ' Author       : Alex_ST
     ' Purpose      : возвращает число уникальных значений в указанном диапазоне
     '---------------------------------------------------------------------------------------
     Dim iArr, Arr(): Arr = Intersect(Диапазон.Parent.UsedRange, Диапазон).Value
     With CreateObject("Scripting.Dictionary")
        .CompareMode = vbTextCompare   ' Создаем словарь
        For Each iArr In Arr
           If Trim(iArr) <> "" Then iArr = .Item(Trim(iArr))   'попытка чтения значения по отсутствующему ключу добавит ключ в словарь
        Next
        СЧЁТ_РАЗНЫХ = .Count
     End With
End Function
[/vba]



С уважением,
Алексей
MS Excel 2003 - the best!!!
 
Ответить
СообщениеИспользуя словари (Dictionary), эту UDF можно ещё больше упростить так:
[vba]
Код
Function СЧЁТ_РАЗНЫХ(Диапазон As Range) As Long
     '---------------------------------------------------------------------------------------
     ' Procedure    : СЧЁТ_РАЗНЫХ
     ' Author       : Alex_ST
     ' Purpose      : возвращает число уникальных значений в указанном диапазоне
     '---------------------------------------------------------------------------------------
     Dim iArr, Arr(): Arr = Intersect(Диапазон.Parent.UsedRange, Диапазон).Value
     With CreateObject("Scripting.Dictionary")
        .CompareMode = vbTextCompare   ' Создаем словарь
        For Each iArr In Arr
           If Trim(iArr) <> "" Then iArr = .Item(Trim(iArr))   'попытка чтения значения по отсутствующему ключу добавит ключ в словарь
        Next
        СЧЁТ_РАЗНЫХ = .Count
     End With
End Function
[/vba]

Автор - Alex_ST
Дата добавления - 04.10.2010 в 21:35
Мир MS Excel » Вопросы и решения » Готовые решения » Функция (UDF) "СЧЁТ_РАЗНЫХ" (Возвращает число уникальных значений в диапазоне)
  • Страница 1 из 1
  • 1
Поиск:

Яндекс.Метрика Яндекс цитирования
© 2010-2024 · Дизайн: MichaelCH · Хостинг от uCoz · При использовании материалов сайта, ссылка на www.excelworld.ru обязательна!