У меня давно уже в Personal лежит макрос для поиска уникальных значений в выделенном диапазоне.
Попробуйте:
Попробуйте:
Код |
---|
Sub NoDups_in_Range() '--------------------------------------------------------------------------------------- ' Procedure : NoDups_in_Range ' Author : Alex_ST ' Topic_HEADER : Макрос "NoDups_in_Range" (Подсчёт и вывод уникальных значений в диапазоне) ' Topic_URL : http://www.excelworld.ru/forum/3-39-25849-16-1347208019 ' 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, Range(Addr).Parent.Cells.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 |