Здравствуйте! Есть файл с 10к+ строк и полусотней столбцов. Нужно выделить повторяющиеся ячч. Средствами Условного форматирования Экселя получается медленно ворочающийся файл. Мысль покрасить ячч. средствами VBA родила код: [vba]
Код
… Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Application.EnableEvents = False … For Each Cll ячёйки в диапазоне от первой до яч. в последнем ряду и последнем имеющим непустую ячейку столбце If яч. Cll не пустая For номер ряда rw от начала до последнего For номер столбца col от начала до последнего имеющего непустую ячейку If Cll.Value = Cells(rw, col) And Not Cll.Address = Cells(rw, col).Address Then Cells(rw, col).Interior.ColorIndex = 22 Next: Next: End If: Next
[/vba] … И это выполняется часы. Совпадений не много, нужно покрасить <1к на 500к ячеек. Прошу помощи у того, кто видит, как изменить код для ускорения.
Здравствуйте! Есть файл с 10к+ строк и полусотней столбцов. Нужно выделить повторяющиеся ячч. Средствами Условного форматирования Экселя получается медленно ворочающийся файл. Мысль покрасить ячч. средствами VBA родила код: [vba]
Код
… Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Application.EnableEvents = False … For Each Cll ячёйки в диапазоне от первой до яч. в последнем ряду и последнем имеющим непустую ячейку столбце If яч. Cll не пустая For номер ряда rw от начала до последнего For номер столбца col от начала до последнего имеющего непустую ячейку If Cll.Value = Cells(rw, col) And Not Cll.Address = Cells(rw, col).Address Then Cells(rw, col).Interior.ColorIndex = 22 Next: Next: End If: Next
[/vba] … И это выполняется часы. Совпадений не много, нужно покрасить <1к на 500к ячеек. Прошу помощи у того, кто видит, как изменить код для ускорения.pentium1024
Сообщение отредактировал pentium1024 - Четверг, 09.12.2021, 13:44
… Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Application.EnableEvents = False … For Each Cll ячёйки в диапазоне от первой до яч. в последнем ряду и последнем имеющим непустую ячейку столбце If яч. Cll не пустая For номер ряда rw от начала до последнего For номер столбца col от начала до последнего имеющего непустую ячейку IF CLL.Interior.ColorIndex = 22 THEN GOTO 1 'ЕСЛИ УЖЕ ПОКРАШЕНО-ЗАЧЕМ ПРОВЕРЯТЬ ДАЛЬШЕ? If Cll.Value = Cells(rw, col) And Not Cll.Address = Cells(rw, col).Address Then Cells(rw, col).Interior.ColorIndex = 22 Next Next End If 1 Next
[/vba]
[vba]
Код
… Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Application.EnableEvents = False … For Each Cll ячёйки в диапазоне от первой до яч. в последнем ряду и последнем имеющим непустую ячейку столбце If яч. Cll не пустая For номер ряда rw от начала до последнего For номер столбца col от начала до последнего имеющего непустую ячейку IF CLL.Interior.ColorIndex = 22 THEN GOTO 1 'ЕСЛИ УЖЕ ПОКРАШЕНО-ЗАЧЕМ ПРОВЕРЯТЬ ДАЛЬШЕ? If Cll.Value = Cells(rw, col) And Not Cll.Address = Cells(rw, col).Address Then Cells(rw, col).Interior.ColorIndex = 22 Next Next End If 1 Next
Апострофф, спасибо. Можно также безусловно на 1 после покраски. Только вряд ли это даст в моём случае заметное ускорение, т.к. совпадений на 10к*50=0,5М ячч. не много, <1000. Не догадался об этом, малом количестве совпадений, написать сразу.
Апострофф, спасибо. Можно также безусловно на 1 после покраски. Только вряд ли это даст в моём случае заметное ускорение, т.к. совпадений на 10к*50=0,5М ячч. не много, <1000. Не догадался об этом, малом количестве совпадений, написать сразу.pentium1024
Сообщение отредактировал pentium1024 - Четверг, 09.12.2021, 13:43
Апострофф, но ведь Cll уже покрашена, так что встретится ещё раз ей равенство, нет ли, уже не имеет значения. Но Вы натолкнули меня на важную мысль – проверять не с начала, т.е., если бегать по рядам, то для проверки брать только то, что ниже. Это д. дать результат. Снова спасибо.
Апострофф, но ведь Cll уже покрашена, так что встретится ещё раз ей равенство, нет ли, уже не имеет значения. Но Вы натолкнули меня на важную мысль – проверять не с начала, т.е., если бегать по рядам, то для проверки брать только то, что ниже. Это д. дать результат. Снова спасибо.pentium1024
Сообщение отредактировал pentium1024 - Четверг, 09.12.2021, 13:53
1 все забираем в массив и бежим по нему, а не по ячейкам 2. если значение в массиве не пустое, то обрабатываем 3 помечаем дубли цветом, сразу или сперва накапливая диапазон через Merge, зависит от количества повторов 4 в массиве стираем значение обработанное 5 повторяем с 2 со следующей непустой ячейкой.
но лучше всего скрестить со словарем, не мгновенно но 25 сек, на массиве 10000x50 заполненный произвольными от 1 до 10000
[vba]
Код
Application.ScreenUpdating = False Set dict = CreateObject("Scripting.Dictionary") a = Selection.Value2 Set mrange = Selection mrange.Interior.Pattern = xlNone For i = 1 To UBound(a) For j = 1 To UBound(a, 2) If a(i, j) <> "" Then If dict.exists(a(i, j)) Then If dict(a(i, j)) <> "" Then mrange.Cells(CLng(Split(dict(a(i, j)), ",")(0)), CLng(Split(dict(a(i, j)), ",")(1))).Interior.ColorIndex = 22 dict(a(i, j)) = "" End If mrange.Cells(i, j).Interior.ColorIndex = 22 Else dict.Add a(i, j), i & "," & j End If End If Next Next Application.ScreenUpdating = True
[/vba]
Чето поперли идее 15 сек на тех же данных
[vba]
Код
Application.ScreenUpdating = False Set dict = CreateObject("Scripting.Dictionary") a = Selection.Value2 Set mrange = Selection mrange.Interior.Pattern = xlNone For i = 1 To UBound(a) For j = 1 To UBound(a, 2) If a(i, j) <> "" Then If dict.exists(a(i, j)) Then Set dict(a(i, j)) = Union(mrange.Cells(i, j), dict(a(i, j))) Else Set dict(a(i, j)) = mrange.Cells(i, j) End If End If Next Next For Each Item In dict With dict(Item) If .Cells.Count > 1 Then _ .Interior.ColorIndex = 22 End With Next Application.ScreenUpdating = True
[/vba]
Еще вариант, использовать Replace с использованием формата (Selection для примера) но это не самый быстрый, так просто для демонстрации техники
[vba]
Код
Set MyRange = Selection MyRange.Interior.Pattern = xlNone With Application.ReplaceFormat.Interior .PatternColorIndex = xlAutomatic .ColorIndex = 22 .TintAndShade = 0 .PatternTintAndShade = 0 End With For Each cell In MyRange If cell.Interior.ColorIndex <> 22 And cell <> "" Then _ MyRange.Replace What:=cell, Replacement:=cell, LookAt:=xlWhole, SearchOrder _ :=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=True
Next
[/vba]
1 все забираем в массив и бежим по нему, а не по ячейкам 2. если значение в массиве не пустое, то обрабатываем 3 помечаем дубли цветом, сразу или сперва накапливая диапазон через Merge, зависит от количества повторов 4 в массиве стираем значение обработанное 5 повторяем с 2 со следующей непустой ячейкой.
но лучше всего скрестить со словарем, не мгновенно но 25 сек, на массиве 10000x50 заполненный произвольными от 1 до 10000
[vba]
Код
Application.ScreenUpdating = False Set dict = CreateObject("Scripting.Dictionary") a = Selection.Value2 Set mrange = Selection mrange.Interior.Pattern = xlNone For i = 1 To UBound(a) For j = 1 To UBound(a, 2) If a(i, j) <> "" Then If dict.exists(a(i, j)) Then If dict(a(i, j)) <> "" Then mrange.Cells(CLng(Split(dict(a(i, j)), ",")(0)), CLng(Split(dict(a(i, j)), ",")(1))).Interior.ColorIndex = 22 dict(a(i, j)) = "" End If mrange.Cells(i, j).Interior.ColorIndex = 22 Else dict.Add a(i, j), i & "," & j End If End If Next Next Application.ScreenUpdating = True
[/vba]
Чето поперли идее 15 сек на тех же данных
[vba]
Код
Application.ScreenUpdating = False Set dict = CreateObject("Scripting.Dictionary") a = Selection.Value2 Set mrange = Selection mrange.Interior.Pattern = xlNone For i = 1 To UBound(a) For j = 1 To UBound(a, 2) If a(i, j) <> "" Then If dict.exists(a(i, j)) Then Set dict(a(i, j)) = Union(mrange.Cells(i, j), dict(a(i, j))) Else Set dict(a(i, j)) = mrange.Cells(i, j) End If End If Next Next For Each Item In dict With dict(Item) If .Cells.Count > 1 Then _ .Interior.ColorIndex = 22 End With Next Application.ScreenUpdating = True
[/vba]
Еще вариант, использовать Replace с использованием формата (Selection для примера) но это не самый быстрый, так просто для демонстрации техники
[vba]
Код
Set MyRange = Selection MyRange.Interior.Pattern = xlNone With Application.ReplaceFormat.Interior .PatternColorIndex = xlAutomatic .ColorIndex = 22 .TintAndShade = 0 .PatternTintAndShade = 0 End With For Each cell In MyRange If cell.Interior.ColorIndex <> 22 And cell <> "" Then _ MyRange.Replace What:=cell, Replacement:=cell, LookAt:=xlWhole, SearchOrder _ :=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=True
Вход
Регистрация
Напомнить пароль
Автосумма
Часто используемые
ВПР
ЕСЛИ
СУММЕСЛИ
Финансовые
Логические
Текстовые
Даты и времени 
Ссылки и массивы 
Математические
Другие функции
Проверка свойств и значений
Баз данных
Математические
Обработки массивов
Обработки строк
Преобразования типов данных 
Загрузки данных
Работы с файлами
Обработки системных параметров
Обработки цвета
Работы с датами и временем
Преобразования в системы счисления
Финансовые
