Уникальное значение по 2 условиям

Вход

Регистрация

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

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

Старая форма входа

Страница 1 из 1 1
Модератор форума: китин, _Boroda_

Мир MS Excel » Вопросы и решения » Вопросы по VBA » Уникальное значение по 2 условиям (Макросы/Sub)

Уникальное значение по 2 условиям

gge29

Дата: Пятница, 19.08.2022, 21:07 | Сообщение № 1

Группа: Проверенные

Ранг: Форумчанин

Сообщений: 244

Репутация: 3 ±

Замечаний: 0% ±

Помогите пожалуйста допилить(если возможно)код уникальных значений.Перелопатил весь инет,вот самый оптимальный,но на 1 столбец.Описание внутри файла

К сообщению приложен файл: Unique.xls (39.5 Kb)

Ответить

прохожий2019

Дата: Пятница, 19.08.2022, 23:52 | Сообщение № 2

Группа: Проверенные

Ранг: Старожил

Сообщений: 1242

Репутация: 317 ±

Замечаний: 0% ±

365 Beta Channel

Цитата gge29, 19.08.2022 в 21:07, в сообщении № 1 (

)

вот самый оптимальный

а я бы на словарях делал
сортировку не писал - только выборку уникальных
[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

Ответить

gge29

Дата: Суббота, 20.08.2022, 21:13 | Сообщение № 3

Группа: Проверенные

Ранг: Форумчанин

Сообщений: 244

Репутация: 3 ±

Замечаний: 0% ±

Спасибо!Под основную допилил,подошло

Ответить

Мир MS Excel » Вопросы и решения » Вопросы по VBA » Уникальное значение по 2 условиям (Макросы/Sub)

Страница 1 из 1
1