VBA Function UNIQ | ExcelForum.ru

Функция для подсчёта уникальных значений в отфильтрованной таблице

Максимально сокращаем время на ручную работу. Даже в мелочах. Все использованные команды изучаются на курсе Excel-XL: Макросы VBA Excel с нуля (24 ак.ч.)

Создаём свою функцию, аналога которой в Excel нет.

Эта функция будет считать количество уникальных элементов (значений) в списке, в том числе отфильтрованном. Это могут быть даты, текст, числа - всё, что угодно.
Чтобы забрать эту функцию в свой файл, сделайте следующее:

Сохраните свой файл в формате с поддержкой макросов
Нажмите Alt+F11 и создайте новый модуль (слева, в проводнике, кликните правой кнопкой мыши по любому модулю, и выберите Insert - Module)
Скопируйте в него приведённый ниже код.
Закройте редактор VBA, сохранив внесённые изменения.
Используйте функцию, она называется СчётУникальных
При следующем открытии файла не забудьте включить макросы

Инструкция в картинках - см. пост #лис_ном_336 у меня в Instagram - OLESYA.EXCEL

По уровню сложности такой макрос Вы сможете написать после моего курса «Макросы на VBA с нуля».

Option Base 1 'массив начинается с 1

Function СчётУникальных(Диапазон)
Dim Arr() 'As Date
For Each Rng In Диапазон 'проверяем каждую ячейку диапазона
If Rng.EntireRow.Hidden = False Then 'если строка этой ячейки НЕ скрыта
counter = counter + 1 'считаем порядковый номер текущего значения
If counter > 1 Then 'если значение уже не первое (то есть в массиве что-то есть)
   'то проверяем, есть ли уже в массиве такое значение
   For i = LBound(Arr) To UBound(Arr) 'от первого до последнего элемента массива
If Rng = Arr(i) Then 'если нашли такое же значение
counter = counter - 1 'возвращаем счётчик на своё значение
   GoTo 1 'пропускаем значение, идём к следующему
  End If
  Next i
  End If
  'сюда приходим только если не нашлось совпадений с предыдущими значениями массива, _
то есть мы нашли новое уникальное значение в ячейке
   ReDim Preserve Arr(counter) 'переопределяем размер массива с сохранением имеющихся в нём данных
Arr(counter) = Rng.Value 'записываем значение в массив
End If
1:
Next
СчётУникальных = UBound(Arr) 'массив состоит в итоге из уникальных значений
End Function