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

Вход

Регистрация

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

 

= Мир MS Excel/Уникальное значение по 2 условиям - Мир MS Excel

Старая форма входа
  • Страница 1 из 1
  • 1
Модератор форума: китин, _Boroda_  
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Уникальное значение по 2 условиям (Макросы/Sub)
Уникальное значение по 2 условиям
gge29 Дата: Пятница, 19.08.2022, 21:07 | Сообщение № 1
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 243
Репутация: 3 ±
Замечаний: 0% ±

Помогите пожалуйста допилить(если возможно)код уникальных значений.Перелопатил весь инет,вот самый оптимальный,но на 1 столбец.Описание внутри файла
К сообщению приложен файл: Unique.xls(39.5 Kb)
 
Ответить
СообщениеПомогите пожалуйста допилить(если возможно)код уникальных значений.Перелопатил весь инет,вот самый оптимальный,но на 1 столбец.Описание внутри файла

Автор - gge29
Дата добавления - 19.08.2022 в 21:07
прохожий2019 Дата: Пятница, 19.08.2022, 23:52 | Сообщение № 2
Группа: Проверенные
Ранг: Ветеран
Сообщений: 916
Репутация: 250 ±
Замечаний: 0% ±

365 Beta Channel
вот самый оптимальный
а я бы на словарях делал
сортировку не писал - только выборку уникальных
[vba]
Код
Sub dict()
    Dim d, r, brr()
    Set d = CreateObject("Scripting.Dictionary")
    Set r = Range([A1], [B34])
    arr = r.Value
    For i = LBound(arr) To UBound(arr)
        a = r(i, 1)
        b = r(i, 2)
        k = a & "|" & b
        If Not d.exists(k) Then d.Add k, Array(a, b)
    Next
    n = d.Count
    ReDim brr(1 To n, 1 To 2)
    For i = 1 To n
        c = d.Items()(i - 1)
        brr(i, 1) = c(0)
        brr(i, 2) = c(1)
    Next i
    Sheets("ВЫБОР").[A1].Resize(n, 2) = brr
End Sub
[/vba]
К сообщению приложен файл: Unique.xlsm(21.8 Kb)


Сообщение отредактировал прохожий2019 - Пятница, 19.08.2022, 23:54
 
Ответить
Сообщение
вот самый оптимальный
а я бы на словарях делал
сортировку не писал - только выборку уникальных
[vba]
Код
Sub dict()
    Dim d, r, brr()
    Set d = CreateObject("Scripting.Dictionary")
    Set r = Range([A1], [B34])
    arr = r.Value
    For i = LBound(arr) To UBound(arr)
        a = r(i, 1)
        b = r(i, 2)
        k = a & "|" & b
        If Not d.exists(k) Then d.Add k, Array(a, b)
    Next
    n = d.Count
    ReDim brr(1 To n, 1 To 2)
    For i = 1 To n
        c = d.Items()(i - 1)
        brr(i, 1) = c(0)
        brr(i, 2) = c(1)
    Next i
    Sheets("ВЫБОР").[A1].Resize(n, 2) = brr
End Sub
[/vba]

Автор - прохожий2019
Дата добавления - 19.08.2022 в 23:52
gge29 Дата: Суббота, 20.08.2022, 21:13 | Сообщение № 3
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 243
Репутация: 3 ±
Замечаний: 0% ±

Спасибо!Под основную допилил,подошло
 
Ответить
СообщениеСпасибо!Под основную допилил,подошло

Автор - gge29
Дата добавления - 20.08.2022 в 21:13
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Уникальное значение по 2 условиям (Макросы/Sub)
  • Страница 1 из 1
  • 1
Поиск:

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