Страницы: 1
RSS
Преобразование формулы СЧЁТЕСЛИ, находящей дубли, в макрос, Формула ищет дубли в столбце, но когда много ячеек работает очень долго, макрос ускорит процесс
 
Здравствуйте. Есть формула
Код
=СЧЁТЕСЛИ(A:A;A2)>1

она ищет дубли в столбце А:А, если значение в ячейке имеет дубликат то формула пишет в столбце В:В ИСТИНА, а если значение в ячейке уникальное то ЛОЖЬ.
Формула хорошо работает когда ячеек для проверки несколько тысяч, но с десятками тысяч уже замедляется, а с сотнями считает часами.

Вопрос: можно ли преобразовать эту формулу в макрос, который будет искать в выделенном диапазоне дубли, и если дубли найдены писать слово дубль правее (например дубли ищут в столбце А:А, а если они есть то пишет слово дубль в столбец В:В).
Нужно чтобы слово дубль писалось рядом с каждым значением у которого есть дубль, т.е одинаковые значения в ячейках А3 и А15 и машина пропишет слово дубль правее обоих этих ячеек в В3 и В15
В файле примере для наглядности выделил дубли цветом.
 
zvolkz, здравствуйте

Цитата
zvolkz: Формула хорошо работает когда ячеек для проверки несколько тысяч, но с десятками тысяч уже замедляется, а с сотнями считает часами.
не может она столько считать. Если таких функций несколько, то запускайте по очереди и после получения результат преобразовывайте в значения
Изменено: Jack Famous - 22.06.2022 09:26:59
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
 
Jack Famous, Здравствуйте. Ещё как может, когда перебирает 700 000 ячеек плюс минус. Конечно несколько функций - сколько ячеек для проверки столько и формул в соседнем столбце т.н 700 000 ячеек в А:А и напротив каждой формула СЧЁТЕСЛИ.  
Изменено: zvolkz - 22.06.2022 10:58:29
 
Цитата
Jack Famous: Если таких функций несколько, то запускайте по очереди и после получения результат преобразовывайте в значения
Цитата
zvolkz: Конечно несколько функций - сколько ячеек для проверки столько и формул в соседнем столбце
я имел ввиду формулу, протянутую для конкретного столбца
Преобразовываете в значения? Также быстрее будет работать, если передавать не весь столбец, а реальную его часть с данными
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
 
несколько тысяч формул обрабатываются обычно незаметно, несколько десятков тысяч формул могут обрабатываются незаметно для пользователя, но уже в зависимости от содержимого формул и мощности компьютера (и несколько десятков тысяч - это реально 1, 2, 3 десятка тысяч)
а вот 700 тыс. формул - это уже проблема (и тут уже не важна суть формул или вычислительные возможности компьютера) -это почти гарантированы тормоза в работе с файлом
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете!
 
Попробуйте так
Код
Sub Макрос2()
    Set Dict = CreateObject("Scripting.Dictionary")
    arr = Range("A2:A" & Cells(Rows.Count, 1).End(xlUp).Row)
    For n = 1 To UBound(arr)
        If Not Dict.Exists(arr(n, 1)) Then Dict.Add CStr(arr(n, 1)), "ЛОЖЬ" Else Dict.Item(CStr(arr(n, 1))) = "ИСТИНА"
    Next
    For n = 1 To UBound(arr)
        arr(n, 1) = Dict.Item(CStr(arr(n, 1)))
    Next
    Range("C1:C" & Cells(Rows.Count, 1).End(xlUp).Row) = arr
End Sub
Изменено: Msi2102 - 22.06.2022 11:27:02
 
Вариант)
 
zvolkz, Макрос вместо функций СУММЕСЛИ, СЧЁТЕСЛИ и прочих агрегаций по критерию
Разбирайтесь  :)
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
 
Msi2102 и kain, большое спасибо за Ваши решения, всё работает
Макрос Msi2102 просчитал диапазон А2:А159433 за секунд 35-40.
Jack Famous, буду разбираться), спасибо за помощь.  
 
Цитата
zvolkz: Макрос  Msi2102  просчитал диапазон А2:А159433 за секунд 35-40
очень долго. Макрос написан нормально, поэтому тормоза из-за количества ключей более 100 тыс (список из уникальных значений) и/или очень слабого компа. Если много ключей, то можно использовать коллекции или суперсловари от Виталия. Также можно подключить библу для словарей и использовать раннее связывание (как у меня) - будет заметно быстрее.
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
 
Цитата
написал:
очень долго
Думаю в компе дело, не самые мощные машины стоят. Спасибо за совет.  
 
Цитата
написал:
тормоза из-за количества ключей более 100 тыс
У меня диапазон "A2:A525001" со всеми уникальными ключами (525000) за 17,46094 с.
 
Msi2102, а с ранним связыванием?
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
 
Цитата
Jack Famous написал:
а с ранним связыванием?
Чё-то даже не пробовал. Зато набросал PQ
Код
let
    Источник = Excel.CurrentWorkbook(){[Name="Таблица1"]}[Content],
    Индекс = Table.AddIndexColumn(Источник, "Индекс", 1, 1, Int64.Type),
    Группа = Table.Group(
        Индекс, 
        {"№ в которых нужно искать дубли"}, 
        {{
            "таб", 
            (t) =>
            [s = Table.AddColumn(t, "Истина_Ложь", each if Table.RowCount(t) > 1 then "ИСТИНА" else "ЛОЖЬ")][s] 
        }}),
    Развертывание = Table.Combine(Группа[таб]),
    Сортировка = Table.Sort(Развертывание,{{"Индекс", Order.Ascending}}),
    Удалить = Table.RemoveColumns(Сортировка,{"Индекс"})    
in
    Удалить

Возможно зайдут знатоки PQ и сделают быстрее
Оставил по 100 единиц, кому интересно, можете добавить и посмотреть, что быстрее
Изменено: Msi2102 - 22.06.2022 16:49:43
 
Цитата
Msi2102: Чё-то даже не пробовал
если не сложно, попробуй и сообщи)
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
 
Цитата
Jack Famous написал:
если не сложно, попробуй и сообщи
Сегодня не успею, под вечер работать заставили  :D
 
Msi2102, изверги, конечно)) буду ждать - интересен буст)
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
 
Ну вроде всё. Добавил ещё один алгоритм, в котором избавился от второго цикла, оказался самым быстрым
Вот результаты:
Скрытый текст

Время в картинках
Файл обрезан до с 400 000 до 100
PS: Ещё проверил если всего один ключ, т.е. все одинаковые значения
Изменено: Msi2102 - 22.06.2022 18:20:23
 
Ну и в принципе самый быстрый, это если не важна сортировка начального массива. Массив сортируется и просто проверяется по порядку, алгоритм проверки делал тупо в лоб, поэтому может быть не оптимальным. Время обработки около 1с (0,9 - 1,1). Пробовал добавлять индекс и в конце сортировать в обратную сторону, но результат становится близким к "Макросу4"
Код
Sub Макрос6()
t = Timer
    With ActiveSheet.Sort
        .SortFields.Clear
        .SortFields.Add Key:=Range("A2:A" & Cells(Rows.Count, 1).End(xlUp).Row), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .SetRange Range("A2:A" & Cells(Rows.Count, 1).End(xlUp).Row)
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .Apply
    End With
    arr = Range("A2:A" & Cells(Rows.Count, 1).End(xlUp).Row)
    ReDim arr1(1 To UBound(arr), 1 To 1)
    
    For n = 1 To UBound(arr)
        If n > 1 And n < UBound(arr) Then
            If arr(n, 1) = arr(n + 1, 1) Or arr(n, 1) = arr(n - 1, 1) Then
                arr1(n, 1) = "Истина"
            Else
                arr1(n, 1) = "Ложь"
            End If
        ElseIf n = 1 Then
            If arr(n, 1) = arr(n + 1, 1) Then
                arr1(n, 1) = "Истина"
            Else
                arr1(n, 1) = "Ложь"
            End If
        ElseIf n = UBound(arr) Then
            If arr(n, 1) = arr(n - 1, 1) Then
                arr1(n, 1) = "Истина"
            Else
                arr1(n, 1) = "Ложь"
            End If
        End If
    Next
    Range("F2:F" & Cells(Rows.Count, 1).End(xlUp).Row) = arr1
t = Timer - t
Debug.Print "Без списка - " & t
End Sub
 
Msi2102, спасибо  :idea:
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
 
Msi2102, мощно даже очень.  
Страницы: 1
Наверх