Private Sub NoDups_in_Range()
'---------------------------------------------------------------------------------------
' Procedure    : NoDups_in_Range
' Author       : Alex_ST
' Purpose      : вывод списка уникальных значений из ВИДИМЫХ ячеек задаваемого диапазона с возможностью подсчёта числа повторов
'---------------------------------------------------------------------------------------
       Dim Addr, rRng As Range, rCell As Range
       On Error Resume Next
       '>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
       ' замена Application.InputBox("...", "...", Type:=8), не работающего на других листах и листах с УФ формулой
       Addr = Application.InputBox("Где брать список?", "Выбор диапазона данных", "=" & Selection.Address, Type:=0)
       If TypeName(Addr) = "Boolean" Then Exit Sub    ' если нажали "Отмена", то Addr = False
       Addr = Range(Trim(Mid(Application.ConvertFormula(Addr, xlR1C1, xlA1, True), 2))).AddressLocal(0, 0, 1, 1)
       '<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
       Set rRng = Intersect(Range(Addr).Parent.UsedRange.SpecialCells(xlCellTypeVisible), Range(Addr)): If Err Then Exit Sub
       With CreateObject("Scripting.Dictionary"): .CompareMode = vbTextCompare   ' создаем временный словарь
          For Each rCell In rRng
             If Trim(rCell) <> "" Then .Item(Trim(rCell)) = .Item(Trim(rCell)) + 1   ' попытка записи значения по отсутствующему ключу добавит ключ в словарь
          Next
          If MsgBox("Видимые ячейки указанного диапазона содержат " & vbCrLf & .Count & " уникальных значений." & vbCrLf & _
                    "Вывести список на лист?", vbYesNo Or vbInformation, "Параметры списка") = vbNo Then Exit Sub
          '>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
          ' замена Application.InputBox("...", "...", Type:=8), не работающего на других листах и листах с УФ формулой
          Addr = Application.InputBox("Куда выводить список?", "Выбор диапазона данных", "=" & Selection(1).Address, Type:=0)
          If TypeName(Addr) = "Boolean" Then Exit Sub   ' если нажали "Отмена", то Addr = False
          Addr = Range(Trim(Mid(Application.ConvertFormula(Addr, xlR1C1, xlA1, True), 2))).AddressLocal(0, 0, 1, 1)
          '<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
          Range(Range(Addr)(1, 1), Range(Addr)(.Count, 1)).Value = Application.WorksheetFunction.Transpose(.keys)
          Range(Addr).Parent.Activate  ' перейти к листу, куда выводятся данные
          If MsgBox("Вывести количества в соседний столбец?", vbQuestion + vbYesNo, "Вывод данных") = vbYes Then
             Range(Range(Addr)(1, 2), Range(Addr)(.Count, 2)).NumberFormat = "General"
             Range(Range(Addr)(1, 2), Range(Addr)(.Count, 2)).Value = Application.WorksheetFunction.Transpose(.Items)
             Range(Range(Addr)(1, 1), Range(Addr)(.Count, 2)).Activate  ' выделить диапазон выведенных данных
          Else
             Range(Range(Addr)(1, 1), Range(Addr)(.Count, 1)).Activate  ' выделить диапазон выведенных данных
          End If
       End With
End Sub

If Trim(rCell) <> "" Then .Item(Trim(rCell)) = .Item(Trim(rCell)) + 1

If Trim(rCell) <> "" Then .Item(Trim(rCell)) = 0&