Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
Как ускорить работу макроса заливки ячеек?
 
#1
22.03.2019 10:34:13
Здравствуйте. Есть макрос, который при вводе значения в ячейку E2, подсвечивает красным похожие значения в диапазоне C7:E. Он работает исправно, но крайне медленно. При объеме данных в 20 000 строк, где в каждой строке присутствует искомый элемент, время работы макроса составляет от 5 сек и выше. Есть предположение, что с помощью массива работа макроса будет быстрее.
Поэтому прошу помощи у специалистов в доработке кода макроса, чтобы обращение шло не к ячейкам, а к массиву.
Код
Sub iCol()
Application.EnableEvents = False

Dim iRng As Range, iAddr$
If Len([E2]) > 0 Then
  With Range("C7:E" & ActiveSheet.UsedRange.Rows.Count)
    Range("C7:E" & ActiveSheet.UsedRange.Rows.Count).Font.Color = RGB(0, 0, 0)
    Set iRng = .Find([E2], After:=.Cells(.Cells.Count), LookIn:=xlValues)
    If Not iRng Is Nothing And Len([E2]) > 0 Then
        iAddr = iRng.Address
        Do
            iRng.Font.Color = RGB(218, 16, 16)
            Set iRng = .FindNext(iRng)
        Loop While Not iRng Is Nothing And iRng.Address <> iAddr
    End If
    End With
End If
If Len([E2]) = 0 Then
 Range("C7:E" & ActiveSheet.UsedRange.Rows.Count).Font.Color = RGB(0, 0, 0)
End If

Application.EnableEvents = True

End Sub
 
 
 
#2
22.03.2019 10:56:57
В массиве можно обработать данные, но не закрасить.
"Все гениальное просто, а все простое гениально!!!"
 
 
 
#3
22.03.2019 11:07:28
Nordheim
Может в массиве, выбрать необходимые ячейки, а потом одним разом все закрасить? Может глупость, но как предположение.
 
 
 
#4
22.03.2019 11:18:17
Не массивом, но диапазоном.
Код
Dim rRng As Range
' -----------------------
                If rRng Is Nothing Then
                    Set rRng = Cells(i, 1) ' формируем диапазон
                Else
                    Set rRng = Union(rRng, Cells(i, 1)) 'пополняем диапазон
                End If
' -----------------------
есть ,  красим
        If Not rRng Is Nothing Then ...
 
 
 
#5
22.03.2019 11:22:09
Код
Sub iCol()
Application.ScreenUpdating = False
Dim iRng As Range, aa As Range, iAddr$, a&, b&, c&, Arr()
Set aa = Range("C7:E" & ActiveSheet.UsedRange.Rows.Count)
If Len([E2]) > 0 Then
  Arr = aa.Value: aa.Font.Color = RGB(0, 0, 0)
  For a = 1 To UBound(Arr)
    For b = 1 To UBound(Arr, 2)
      If InStr(1, Arr(a, b), [E2], 1) Then
        If iRng Is Nothing Then Set iRng = aa(a, b) Else Set iRng = Union(iRng, aa(a, b))
      End If
    Next
  Next
  If Not iRng Is Nothing Then iRng.Font.Color = RGB(218, 16, 16)
Else: aa.Font.Color = RGB(0, 0, 0)
End If
Application.ScreenUpdating = True
End Sub

Не проверял.
Изменено: Anchoret - 22.03.2019 20:02:46
 
 
 
#6
22.03.2019 11:44:29
Anchoret, спасибо, вроде работает. Потестирую, отпишусь.
vikttur, если не трудно, покажите, где в моем коде ваш код применить?
 
 
 
#7
22.03.2019 11:47:50
Anchoret все показал, там то же самое
 
 
 
#8
22.03.2019 12:48:36
Anchoret
В моем примере поиск и закрашивание идет, если в E2 введен хотя бы один символ из диапазона C7:E (если в E2 = T или E2 = ты , закрашиваем все ячейки, где есть символ т или ты, например Тыква). В вашем коде для поиска необходимо полное соответствие E2 и искомого слова в диапазоне C7:E.
Можно как-то это исправить?
Изменено: Hashtag - 22.03.2019 13:13:57
 
 
 
#9
22.03.2019 13:53:11
Цитата
Hashtag написал:
Можно как-то это исправить?
Поставьте вместо знака сравнения Like. Что то типа
Скрытый текст
Изменено: Nordheim - 22.03.2019 13:58:18
"Все гениальное просто, а все простое гениально!!!"
 
 
 
#10
22.03.2019 16:17:38
Nordheim
Такой вариант не помог
Код
If [E2] Like arr(a, b) Then
 
 
 
#11
22.03.2019 17:58:39
Hashtag, изменил код выше.
 
 
 
#12
22.03.2019 18:25:04
Цитата
Hashtag написал:
при вводе значения в ячейку E2, подсвечивает красным похожие значения в диапазоне C7:E.
Цитата
Hashtag написал:
При объеме данных в 20 000 строк, где в каждой строке присутствует искомый элемент, время работы макроса составляет от 5 сек и выше.
1. Интересно, что Вы ищете в этом Алгоритме?  ;)
2. Как успевает Ваш Юзер на таком "безумном" объеме что-либо просто ЗАМЕТИТЬ?!  8-0  8-0  8-0
Вы, полагаю, так называемый - Генератор Идей Автоматизации...  :D
 
 
 
#13
22.03.2019 18:41:05
Цитата
Мотя написал: что Вы ищете в этом Алгоритме
Ищу смысл бытия  :)

Цитата
Мотя написал: так называемый - Генератор Идей Автоматизации...  
Как вам будет угодно.
 
 
 
#14
22.03.2019 18:46:26
Цитата
Hashtag написал:
Такой вариант не помог
Я в примере такой вариант не показывал.
"Все гениальное просто, а все простое гениально!!!"
 
 
 
#15
22.03.2019 18:54:13
Nordheim
Так никто ничего не говорит. Я сам его не правильно использовал.
 
 
 
#16
22.03.2019 20:01:18
Точнее вот так.
 
 
 
#17
22.03.2019 20:01:22
Anchoret
Ваш код на 1 секунду быстрей отрабатывает. Думал , что быстрее будет, но нет. А вообще быстрее его можно сделать или в этой ситуации это предел возможностей?
 
 
 
#18
22.03.2019 20:05:14
Hashtag, Формул, форматов, Уф много в открытых книгах? Если да, то стоит еще отключать/включать калькуляцию. А так ускорить можно, если написать алгоритм поиска отличный от тупого перебора элементов массива) Еще есть вариант при переборе массива в отдельный массив скидывать адреса ячеек с найденным вхождением, а потом разом слить этот массив в строку через запятую и скормить ее оператору Range.
-------------
Нет , так не выйдет. Видимо ограничение на количество операндов в Range.
Изменено: Anchoret - 22.03.2019 20:25:03
 
 
 
#19
22.03.2019 20:17:33
Anchoret
Проверял на пустой книге, где только ваш код и все. На 20 000 строк мой код - 3,6 сек, ваш код 2,9.
А алгоритм поиска отличный от тупого перебора элементов массива будет сложно написать?
 
 
 
#20
22.03.2019 20:25:32
Hashtag, попробуйте)
 
 
 
#21
22.03.2019 20:27:56
Anchoret
Ну, спасибо! )
 
 
 
#22
22.03.2019 20:50:32
С таймером в [F2] и не только:
Код
Sub iCol()
Application.ScreenUpdating = False
Dim iRng As Range, aa As Range, iAddr$, a&, b&, Arr(), t#
Set aa = Range("C7:E" & Cells(Rows.Count, "C").End(xlUp).Row): t = Timer
If Len([E2]) > 0 Then
  Arr = aa.Value: aa.Font.Color = RGB(0, 0, 0)
  For a = 1 To UBound(Arr)
    For b = 1 To UBound(Arr, 2)
      If InStr(1, Arr(a, b), [E2], 1) Then
        If iRng Is Nothing Then Set iRng = aa(a, b) Else Set iRng = Union(iRng, aa(a, b))
      End If
    Next
    If a Mod 100 = 0 Then Application.StatusBar = "Процент выполнения задачи: " & Int(a / UBound(Arr) * 100) & "%"
  Next
  Application.StatusBar = "Процент выполнения задачи: " & Int(a / UBound(Arr) * 100) & "%"
  If Not iRng Is Nothing Then iRng.Font.Color = RGB(218, 16, 16)
Else: aa.Font.Color = RGB(0, 0, 0)
End If: [F2].NumberFormat = "@": [F2] = Format(Timer - t, "0.000")
Application.ScreenUpdating = True
End Sub

На самом деле обход только массива - сотые доли секунды, всё остальное работа с диапазоном. Поэтому решения у этой задачи скорее всего нет.
Изменено: Anchoret - 22.03.2019 21:05:49
 
 
 
#23
22.03.2019 23:25:42
Anchoret
Цитата
Anchoret написал: решения у этой задачи скорее всего нет
На нет и суда нет. Вы и так большой молодец! Спасибо вам за труды.
 
 
 
#24
22.03.2019 23:39:03
Есть
 
 
 
#25
23.03.2019 00:40:58
Hashtag, другой подход: поиск-замена может менять цвет. Упростил обе процедуры
Код
'код листа

Private Sub Worksheet_Change(ByVal Target As Range)
  If Target.Address = "$E$2" Then iCol CStr(Target)
End Sub

'код модуля

Sub iCol(s As String)
  With Range("C7:E" & ActiveSheet.UsedRange.Rows.Count)
    If Len(s) Then
      Application.ReplaceFormat.Font.Color = RGB(218, 16, 16)
      .Replace What:=s, Replacement:="", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=True
    Else
      .Font.Color = RGB(0, 0, 0)
    End If
  End With
End Sub
 
 
 
#26
25.03.2019 08:28:51
Hashtag, вариант от Казанского скорее всего, будет быстрее (и точно проще и понятнее в плане кода), но для общего развития скажу, что ещё можно собирать в одномерный массив arr1x() адреса ячеек, а потом махом из них сформировать массив Set rng=Range(Join(arr1x,",")) и делать с ним всё, что угодно. Для формирования массива советую использовать функцию отсюда.

P.S.: массив адресов нужно собирать не через Range().Address (это очень долго), а с помощью счётчиков для строк и столбцов от первой ячейки диапазона.

UPD: RAN в #24 даёт ссылку на тему. В конце этой темы RAN же даёт ссылку вот на эту тему, уже в конце которой (#33) можно увидеть решение, очень похожее на тот вариант, что предложил я  :D
Изменено: Jack Famous - 25.03.2019 10:18:50
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
 
 
 
#27
26.03.2019 10:15:48
Казанский
Не ожидал такого быстрого решения. Результат - менее секунды, отлично. Спасибо вам большое.
RAN, Jack Famous
Спасибо за ваши рекомендации, попробую вникнуть.
 
 
 
Страницы: 1
Наверх