Тесты. Как быстро закрасить ячейки, AddressCut / AddressToMaxRanges. Функция для резки одного длинного адреса на блоки максимальной длины (~ 255 символов) с преобразованием в диапазоны
Основная задача: найти наибыстрейший метод для закрашивания ячеек Подзадача: Поработать над универсальностью (передал аргумент для обработки и не паришься)
Модуль «Macro»
Код
Option Explicit
Option Private Module
'====================================================================================================
Dim arrRng() As Range, arrAdr()
Const nMax& = 1000000
'====================================================================================================
Sub Tester()
Dim x, arr()
Dim tx$, t!, tt!, i&
tt = Timer
' CHOOSE RANGE ======================================================
'GetAdr_500k_Single ' 1 sec
'GetAdr_500k_Ranges ' 1.5 sec
'GetAdr_4x250k_Single ' 2.2 sec
'GetAdr_4x250k_Ranges ' 3 sec
'GetAdr_4x1mln_Single ' 8.9 sec
GetAdr_4x1mln_Range ' 12.5 sec
' Test ONE color (SIMPLE) ===========================================
't = Timer
' For Each x In FILE_RangesFromAddress_OLD(Join(arrAdr, ","))
' x.Interior.Color = vbYellow
' Next x
'Debug.Print "Cut & Paint (OLD):", Format$(Timer - t, "0.000 sec") ' 31 sec = 30 (cut) + 1 (paint)
't = Timer
' For Each x In FILE_BlocksFromAddress(Join(arrAdr, ","))
' Range(x).Interior.Color = vbYellow ' 1.5 sec (0.1 + 1.4 sec) / 2.33 sec
' Next x
'Debug.Print "BlocksFromAddress:", Format$(Timer - t, "0.000 sec")
'
't = Timer
' For Each x In FILE_RangesFromAddress(Join(arrAdr, ","))
' x.Interior.Color = vbYellow ' 1.4 sec / 2.19 sec
' Next x
'Debug.Print "RangesFromAddress:", Format$(Timer - t, "0.000 sec")
'
't = Timer
' FILE_PaintFromAddress Join(arrAdr, ",")
'Debug.Print "PaintFromAddress:", Format$(Timer - t, "0.000 sec") ' 1.45 / 2.27 sec
' Test 4 color (REAL LIFE) ==========================================
arr = Array(vbGreen, vbYellow, vbCyan, vbRed)
t = Timer
For i = 0 To UBound(arrAdr)
For Each x In FILE_BlocksFromAddress(Join(arrAdr(i), ",")) ' ======================== TYPES ==================================
Range(x).Interior.Color = arr(i)
Next x ' s4*250k r4*250k s4*1mln r4*1mln
Next i
Debug.Print "Blocks 4x:", Format$(Timer - t, "0.000 sec") ' 3: 3.08 / 4.83 / 12.2 / 18.8
t = Timer
For i = 0 To UBound(arrAdr)
tx = Join(arrAdr(i), ",")
FILE_PaintFromAddress tx, , arr(i)
Next i
Debug.Print "Paint 4x:", Format$(Timer - t, "0.000 sec") ' 2: 2.94 / 4.63 / 11.6 / 18.0
t = Timer
For i = 0 To UBound(arrAdr)
For Each x In FILE_RangesFromAddress(Join(arrAdr(i), ",")) ' 1: 2.83 / 4.47 / 11.3 / 17.3
x.Interior.Color = arr(i)
Next x
Next i
Debug.Print "Ranges 4x:", Format$(Timer - t, "0.000 sec")
t = Timer
Erase arrRng: Erase arrAdr:
Debug.Print "Clear variables:", Format$(Timer - t, "0.000 sec") ' 0.2
Debug.Print "Time total:", Format$(Timer - tt, "0.000 sec")
End Sub
'====================================================================================================
'====================================================================================================
'====================================================================================================
'====================================================================================================
'====================================================================================================
Sub GetAdr_500k_Single() ' 1 sec (500k single cells)
Dim t!, r&, i&
t = Timer
ReDim arrAdr(nMax / 2 - 1): i = -1
For r = 2 To nMax Step 2
i = i + 1
arrAdr(i) = Cells(r, 1).Address(0, 0, xlA1)
Next r
Debug.Print "Get Adr 500k Single:", Format$(Timer - t, "0.0 sec")
End Sub
'====================================================================================================
Sub PaintSimple_500k_Single() ' 6 sec
Dim t!, r&
t = Timer
With Application: .ScreenUpdating = False: .DisplayAlerts = False: .EnableEvents = False: End With
For r = 2 To nMax Step 2
Cells(r, 1).Interior.Color = vbYellow
Next r
With Application: .ScreenUpdating = True: .DisplayAlerts = True: .EnableEvents = True: End With
Debug.Print "Paint simple 500k Single:", Format$(Timer - t, "0.0 sec")
End Sub
'====================================================================================================
'====================================================================================================
'====================================================================================================
Sub GetAdr_500k_Ranges() ' 1.5 sec (500k ranges, 10 cells each range)
Dim t!, r&, i&
t = Timer
ReDim arrAdr(nMax / 2 - 1): i = -1
For r = 2 To nMax Step 2
i = i + 1
arrAdr(i) = Cells(r, 1).Resize(1, 10).Address(0, 0, xlA1)
Next r
Debug.Print "Get Adr 500k ranges:", Format$(Timer - t, "0.0 sec")
End Sub
'====================================================================================================
Sub PaintSimple_500k_Ranges() ' 10.3 sec
Dim t!, r&
t = Timer
With Application: .ScreenUpdating = False: .DisplayAlerts = False: .EnableEvents = False: End With
For r = 2 To nMax Step 2
Cells(r, 1).Resize(1, 10).Interior.Color = vbYellow
Next r
With Application: .ScreenUpdating = True: .DisplayAlerts = True: .EnableEvents = True: End With
Debug.Print "Paint simple 500k Ranges:", Format$(Timer - t, "0.0 sec")
End Sub
'====================================================================================================
'====================================================================================================
'====================================================================================================
Sub GetAdr_4x250k_Single() ' 2.3 sec (4 colors, 250k single cells each type)
Dim arrG() As String, arrY() As String, arrC() As String, arrR() As String
Dim t!, r&, i&
t = Timer
ReDim arrAdr(3): i = -1
ReDim arrG(nMax / 4 - 1): ReDim arrY(UBound(arrG)): ReDim arrC(UBound(arrG)): ReDim arrR(UBound(arrG))
For r = 4 To nMax Step 4
i = i + 1
arrG(i) = Cells(r - 3, 1).Address(0, 0, xlA1)
arrY(i) = Cells(r - 2, 1).Address(0, 0, xlA1)
arrC(i) = Cells(r - 1, 1).Address(0, 0, xlA1)
arrR(i) = Cells(r, 1).Address(0, 0, xlA1)
Next r
arrAdr(0) = arrG: arrAdr(1) = arrY: arrAdr(2) = arrC: arrAdr(3) = arrR
Debug.Print "Get Adr 4x250k Single:", Format$(Timer - t, "0.0 sec")
End Sub
'====================================================================================================
Sub PaintSimple_4x250k_Single() ' 11.8 sec
Dim t!, r&
t = Timer
With Application: .ScreenUpdating = False: .DisplayAlerts = False: .EnableEvents = False: End With
For r = 4 To nMax Step 4
Cells(r - 3, 1).Interior.Color = vbGreen
Cells(r - 2, 1).Interior.Color = vbYellow
Cells(r - 1, 1).Interior.Color = vbCyan
Cells(r, 1).Interior.Color = vbRed
Next r
With Application: .ScreenUpdating = True: .DisplayAlerts = True: .EnableEvents = True: End With
Debug.Print "Paint simple 4x250k Single:", Format$(Timer - t, "0.0 sec")
End Sub
'====================================================================================================
'====================================================================================================
'====================================================================================================
Sub GetAdr_4x250k_Ranges() ' 3 sec
Dim arrG() As String, arrY() As String, arrC() As String, arrR() As String
Dim t!, r&, i&
t = Timer
ReDim arrAdr(3): i = -1
ReDim arrG(nMax / 4 - 1): ReDim arrY(UBound(arrG)): ReDim arrC(UBound(arrG)): ReDim arrR(UBound(arrG))
For r = 4 To nMax Step 4
i = i + 1
arrG(i) = Cells(r - 3, 1).Resize(1, 10).Address(0, 0, xlA1)
arrY(i) = Cells(r - 2, 1).Resize(1, 10).Address(0, 0, xlA1)
arrC(i) = Cells(r - 1, 1).Resize(1, 10).Address(0, 0, xlA1)
arrR(i) = Cells(r, 1).Resize(1, 10).Address(0, 0, xlA1)
Next r
arrAdr(0) = arrG: arrAdr(1) = arrY: arrAdr(2) = arrC: arrAdr(3) = arrR
Debug.Print "Get Adr 4x250k Ranges:", Format$(Timer - t, "0.0 sec")
End Sub
'====================================================================================================
Sub PaintSimple_4x250k_Ranges() ' 21.5 sec
Dim t!, r&
t = Timer
With Application: .ScreenUpdating = False: .DisplayAlerts = False: .EnableEvents = False: End With
For r = 4 To nMax Step 4
Cells(r - 3, 1).Resize(1, 10).Interior.Color = vbGreen
Cells(r - 2, 1).Resize(1, 10).Interior.Color = vbYellow
Cells(r - 1, 1).Resize(1, 10).Interior.Color = vbCyan
Cells(r, 1).Resize(1, 10).Interior.Color = vbRed
Next r
With Application: .ScreenUpdating = True: .DisplayAlerts = True: .EnableEvents = True: End With
Debug.Print "Paint simple 4x250k Ranges:", Format$(Timer - t, "0.0 sec")
End Sub
'====================================================================================================
'====================================================================================================
'====================================================================================================
Sub GetAdr_4x1mln_Single() ' 8.9 sec
Dim arrG() As String, arrY() As String, arrC() As String, arrR() As String
Dim x, arr(), t!, r&, i&
t = Timer
arr = Array(1, 11, 21, 31)
ReDim arrAdr(3): i = -1
ReDim arrG(nMax - 1): ReDim arrY(UBound(arrG)): ReDim arrC(UBound(arrG)): ReDim arrR(UBound(arrG))
For r = 4 To nMax Step 4
For Each x In arr
i = i + 1
arrG(i) = Cells(r - 3, x).Address(0, 0, xlA1)
arrY(i) = Cells(r - 2, x).Address(0, 0, xlA1)
arrC(i) = Cells(r - 1, x).Address(0, 0, xlA1)
arrR(i) = Cells(r, x).Address(0, 0, xlA1)
Next x
Next r
arrAdr(0) = arrG: arrAdr(1) = arrY: arrAdr(2) = arrC: arrAdr(3) = arrR
Debug.Print "Get Adr 4x1mln Single:", Format$(Timer - t, "0.0 sec")
End Sub
'====================================================================================================
Sub PaintSimple_4x1mln_Single() ' 47.5 sec
Dim x, arr(), t!, r&
t = Timer
With Application: .ScreenUpdating = False: .DisplayAlerts = False: .EnableEvents = False: End With
arr = Array(1, 11, 21, 31)
For r = 4 To nMax Step 4
For Each x In arr
Cells(r - 3, x).Interior.Color = vbGreen
Cells(r - 2, x).Interior.Color = vbYellow
Cells(r - 1, x).Interior.Color = vbCyan
Cells(r, x).Interior.Color = vbRed
Next x
Next r
With Application: .ScreenUpdating = True: .DisplayAlerts = True: .EnableEvents = True: End With
Debug.Print "Paint simple 4x1mln Single:", Format$(Timer - t, "0.0 sec")
End Sub
'====================================================================================================
'====================================================================================================
'====================================================================================================
Sub GetAdr_4x1mln_Range() ' 12.5 sec
Dim arrG() As String, arrY() As String, arrC() As String, arrR() As String
Dim x, arr(), t!, r&, i&
t = Timer
arr = Array(1, 11, 21, 31)
ReDim arrAdr(3): i = -1
ReDim arrG(nMax - 1): ReDim arrY(UBound(arrG)): ReDim arrC(UBound(arrG)): ReDim arrR(UBound(arrG))
For r = 4 To nMax Step 4
For Each x In arr
i = i + 1
arrG(i) = Cells(r - 3, x).Resize(1, 10).Address(0, 0, xlA1)
arrY(i) = Cells(r - 2, x).Resize(1, 10).Address(0, 0, xlA1)
arrC(i) = Cells(r - 1, x).Resize(1, 10).Address(0, 0, xlA1)
arrR(i) = Cells(r, x).Resize(1, 10).Address(0, 0, xlA1)
Next x
Next r
arrAdr(0) = arrG: arrAdr(1) = arrY: arrAdr(2) = arrC: arrAdr(3) = arrR
Debug.Print "Get Adr 4x1mln Single:", Format$(Timer - t, "0.0 sec")
End Sub
'====================================================================================================
Sub PaintSimple_4x1mln_Range() ' 101.1 sec
Dim x, arr(), t!, r&
t = Timer
With Application: .ScreenUpdating = False: .DisplayAlerts = False: .EnableEvents = False: End With
arr = Array(1, 11, 21, 31)
For r = 4 To nMax Step 4
For Each x In arr
Cells(r - 3, x).Resize(1, 10).Interior.Color = vbGreen
Cells(r - 2, x).Resize(1, 10).Interior.Color = vbYellow
Cells(r - 1, x).Resize(1, 10).Interior.Color = vbCyan
Cells(r, x).Resize(1, 10).Interior.Color = vbRed
Next x
Next r
With Application: .ScreenUpdating = True: .DisplayAlerts = True: .EnableEvents = True: End With
Debug.Print "Paint simple 4x1mln Single:", Format$(Timer - t, "0.0 sec")
End Sub
'====================================================================================================
Модуль «Func»
Код
Option Explicit
Option Private Module
'====================================================================================================
Function FILE_RangesFromAddress_OLD(ByVal txAdr$, Optional sh As Worksheet) As Range()
Dim arrRanges() As Range, r&, i&
If sh Is Nothing Then Set sh = ActiveSheet
If InStr(txAdr, "$") Then txAdr = Replace$(txAdr, "$", "")
i = Len(txAdr)
If i < 256 Then ' если адрес и так влазит, то содаём массив из 1го элемента и выходим
ReDim arrRanges(0)
Set arrRanges(0) = sh.Range(txAdr): GoTo fin
End If
r = -1: ReDim arrRanges(i \ 200) ' создаём массив для хранения с запасом
Do
i = InStrRev(Left$(txAdr, 255), ",") ' ищем запятую с конца первых 255 символов взятой строки
r = r + 1: Set arrRanges(r) = sh.Range(Left$(txAdr, i - 1)) ' заполняем массив диапазонов
txAdr = Mid$(txAdr, i + 1) ' отрезаем от адресной строки использованный фрагмент (взятая строка)
If Len(txAdr) < 256 Then ' если остаток строки можно сразу преобразовать в диапазон, то заканчиваем и выходим
r = r + 1: Set arrRanges(r) = sh.Range(Left$(txAdr, i - 1))
ReDim Preserve arrRanges(r): GoTo fin
End If
Loop
fin: FILE_RangesFromAddress_OLD = arrRanges
End Function
'====================================================================================================
Function FILE_BlocksFromAddress(ByVal txAdr$) As String()
Dim arr() As String
Dim l&, n&, i&, p&, m&
If InStr(txAdr, "$") Then txAdr = Replace$(txAdr, "$", "")
l = Len(txAdr): If l < 256 Then ReDim arr(0): arr(0) = txAdr: GoTo fin
m = l - 256 ' позиция, после которой весь остаток влезет в 1 блок
ReDim arr(l \ 200): n = -1
Do
i = InStrRev(txAdr, ",", p + 256)
n = n + 1: arr(n) = Mid$(txAdr, p + 1, i - p - 1)
p = i
If p > m Then
n = n + 1: arr(n) = Right$(txAdr, l - p)
ReDim Preserve arr(n): GoTo fin
End If
Loop
fin: FILE_BlocksFromAddress = arr
End Function
'====================================================================================================
Function FILE_RangesFromAddress(ByVal txAdr$, Optional sh As Worksheet) As Range()
Dim arr() As Range
Dim l&, n&, i&, p&, m&
If sh Is Nothing Then Set sh = ActiveSheet
If InStr(txAdr, "$") Then txAdr = Replace$(txAdr, "$", "")
l = Len(txAdr): If l < 256 Then ReDim arr(0): Set arr(0) =sh.Range( txAdr): GoTo fin
m = l - 256
ReDim arr(l \ 200): n = -1
Do
i = InStrRev(txAdr, ",", p + 256)
n = n + 1: Set arr(n) = sh.Range(Mid$(txAdr, p + 1, i - p - 1))
p = i
If p > m Then
n = n + 1: Set arr(n) = sh.Range(Right$(txAdr, l - p))
ReDim Preserve arr(n): GoTo fin
End If
Loop
fin: FILE_RangesFromAddress = arr
End Function
'====================================================================================================
Sub FILE_PaintFromAddress(ByVal txAdr$, Optional sh As Worksheet, Optional ByVal iColor&)
Dim l&, i&, p&, m&
If sh Is Nothing Then Set sh = ActiveSheet
If iColor = 0 Then iColor = vbYellow
If InStr(txAdr, "$") Then txAdr = Replace$(txAdr, "$", "")
l = Len(txAdr): If l < 256 Then sh.Range(txAdr).Interior.Color = iColor: Exit Sub
m = l - 256
Do
i = InStrRev(txAdr, ",", p + 256)
sh.Range(Mid$(txAdr, p + 1, i - p - 1)).Interior.Color = iColor
p = i: If p > m Then sh.Range(Right$(txAdr, l - p)).Interior.Color = iColor: Exit Sub
Loop
End Sub
'====================================================================================================
Итоги
Тесты показывают стабильное и растущее с объёмом заливки преимущество метода резки строки адресов на группы перед ближайшим соперником - закрашиванием "в лоб" в цикле Среди самих 3ёх вариантов функции стабильно быстрее при равном удобстве функция RangesFromAddress - прирост от 3,8 до 5% (дальше беру её и остальные не рассматриваю)
Функция резки строк, что была у меня раньше безбожно тормозила - закрашивание "в лоб" в цикле было в 5 раз быстрее (6 против 30 секунд) Причина: брать части строки в переменные - плохая идея, если строка состоит из миллионов символов Решение: работать с 2мя указателями (конец прошлой строки и очередной). Прирост скорости в десятки (при росте объёмов и в сотни) раз (0,5 секунды против 30 на 500 тыс отдельных ячеек - только резка) Закрашивание сразу при резке незаметно, но стабильно проигрывает созданию массива, причём создание массива "укрупнённых" адресов тоже немного, но стабильно проигрывает созданию массива диапазонов (хотя мне казалось, что должно быть наоборот)
В любом случае, это отличные новости, ведь можно передавать массив строк с листом и практически мгновенно (доли секунды) получить массив диапазонов С ними можно делать всё, что угодно - красить, объединять, очищать. Если я правильно понимаю, то ЛЮБОЕ действие в цикле по "укрупнённым" диапазонам будет быстрее, чем, без "укрупнения" Особенно это важно, если нужно получить из отдельных областей один массив с помощью Union: функция эта медлительная и чем её реже вызывать, там лучше (а также забивать всеми 30ю аргументами). При резке количество диапазонов сокращается в десятки и сотни раз - выгода очевидна
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
vikttur, уже поменял местами. Связь такая, что эта функция используется, чтобы закрашивать ячейки максимально быстро. То есть пример демонстрирует преимущество функции
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Jack Famous написал: брать части строки в переменные - плохая идея, если строка состоит из миллионов символов
Я тебе еще в первой теме в первом сообщении это написал. На что ты отвечал что работа в VBA со строками очень быстра и т.д., но не будем поднимать, как говорится.
Цитата
Jack Famous написал: Задача: определить баланс между удобством и скоростью работы при закрашивании ячеек
Плохая формулировка, кто будет определять, в каком решении лучше баланс? Вот, скорость она объективна, а баланс это субъективное понятие. У каждого свой баланс, как выяснили по трем предыдущим темам. Давай стенд и на скорость?
bedvit, ну стэнд готов в файле. Жду Про строки Виталь, ну сколько можно - и там, и тут работа со строками, просто тут более правильно и сильно быстрее. Хватит уже с "я же говорил"
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
bedvit, хорошо, если получится ещё заметно быстрее Только сразу прикидывай, если нужно будет собирать не 1, а несколько диапазонов и красить в разные цвета, как в ColorMap (кстати, я обновил) Считать длину накопленный строки и укрупнять в цикле, как было у тебя с Select'ом должно быть медленнее, но ХЗ, как на самом деле получится
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
'====================================================================================================
Function FILE_BlocksFromAddress(ByVal txAdr$) As String() ' вернёт массив из 15 883 элементов при 500k отдельных ячеек или 32 734 эл. при 500k диапазонов по 10 ячеек
Dim arr() As String
Dim l&, n&, i&, p& ', m&
If InStr(txAdr, "$") Then txAdr = Replace$(txAdr, "$", "")
l = Len(txAdr): If l < 256 Then ReDim arr(0): arr(0) = txAdr: GoTo fin
'm = l - 256 ' позиция, после которой весь остаток влезет в 1 блок
ReDim arr(l \ 200): n = -1
Do
i = InStrRev(txAdr, ",", p + 255) ' при изменении 255 на 256 удалось уменьшить количество получаемых "блоков" адресов с 15 883 до 15 430 (-453) и с 32 734 до 30 859 (-1 875) - соответственно для 500k отдельных ячеек или диапазонов по 10 ячеек
n = n + 1: arr(n) = Mid$(txAdr, p + 1, i - p - 1)
p = i
If l - p < 256 Then
' If p > m Then ' замена «If l - p < 256 Then» на «If p>m Then» увеличит скорость
n = n + 1: arr(n) = Right$(txAdr, l - p)
ReDim Preserve arr(n): GoTo fin
End If
Loop
fin: FILE_BlocksFromAddress = arr
End Function
'====================================================================================================
объём не позволяет достоверно узнать, насколько (процесс резки занимает сотые доли секунды, что соизмеримо с погрешностью), поэтому готовлю ещё 2 теста: 4 раза по 250k отдельных ячеек разными цветами (миллион) и то же самое, но не отдельных ячеек, а диапазонов по 10 ячеек в каждом
UPD: 4 массива по 250 тыс адресов отдельных ячеек режет за 0,15-0,16 сек (сбор адресов - 2,2 сек) Разница в скорости всё также незаметна (очень быстро, но при закрашивании количество блоков очень важно, ведь это размер цикла, так что посмотрим)
ВАЖНО: закрашивание 1 млн отдельных ячеек 4мя разными цветами "в лоб" занимает всего 11-12 сек (на 0,5 - 1 сек дольше, чем закрашивание "в лоб" одним цветом 500 тыс ячеек). Это очень быстро, при этом ,как говорит дядь медведь, это "тупой код" (простой и не требующий выпендрёжа типа моих функции для резки)
UPD2: закрашивание "укрупнённых" диапазонов занимает ~2,7-2,9 сек (4*250k single cells), что в итоге даёт общее время (сбор + резка + окраска) в ~ 5 секунд, что более, чем в 2 раза быстрее, чем "в лоб" Ускорения, описанные под спойлером дали прирост в скорости этого теста на 0,2-0,3 сек — незаметно, но стабильно и с ростом объёмов будет гарантированно увеличиваться
UPD3 (4*250k ranges, 10 cells each range): метод "в лоб" с результатом в 21,5 сек против 7,5 сек (3 сбор адресов + 4,5 резка и окрашивание) теперь отстаёт почти в 3 раза
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Sub SelectCells()
Dim t, y, arr, i, sc, ac
t = Timer
With Application: .StatusBar = "bedvit...": .ScreenUpdating = 0: .DisplayAlerts = 0: .EnableEvents = 0: ac = .Calculation: .Calculation = -4135: End With
ReDim arr(1 To Rows.Count, 1 To 1)
For i = 2 To Rows.Count Step 2
arr(i, 1) = 1
Next
Cells(1, 1).Resize(Rows.Count, 1) = arr
Set sc = Cells(2, 1).Resize(Rows.Count - 1, 10)
sc.AutoFilter
sc.AutoFilter Field:=1, Criteria1:="<>"
Set sc = sc.SpecialCells(xlCellTypeVisible)
sc.AutoFilter Field:=1
sc.Interior.Color = 65535
Selection.AutoFilter
sc.ClearContents
[a1].Select
With Application: .ScreenUpdating = 1: .DisplayAlerts = 1: .EnableEvents = 1: .Calculation = ac: .StatusBar = False: End With
Debug.Print "bedvit Total: " & Timer - t
End Sub
старые, наверное, сейчас 4,08 на твоих условиях (диапазоны по 10 ячеек со втрой строки и до конца каждую втору строку) — не выиграл (твой результат также 4,7 показал у меня)
обрати внимание, что опять ты начинаешь считать символы (тебе платят за это или место в редакторе экономишь ?) и опять неверно, т.к. функций всего 2 (сбор адресов и резка адресов) + 1 основная тестовая процедура: • сбор адресов можно запихнуть в тестовую процедуру, но удобнее вызывать отдельно, т.к. у меня уже больше 6ти вариантов тестирования • резку запихать, конечно тоже можно, но это уже контпродуктивно - это отдельная функция для вызова, откуда угодно (писал про модульный подход в ColorMap, где ты мне так и не ответил по готовому решению)
Скоро выложу полный тестовый стенд с различными вариантами закрашивания: при количестве цветов более одного и/или расположении ячеек в разных столбцах/строках (шахматка) твой метод "отфильтровал-закрасил" сильно отстанет — будешь продолжать соревнование?
Чтобы ты понимал, я не создаю искусственные условия, чтобы победить, но как раз наоборот: в реальности (в той же ColorMap) нужно выделять диапазоны по всему листу и разными цветами. Для моей функции это вообще не проблема и она выдаст примерно линейный рост времени работы при увеличении количества участвующих в окрашивании ячеек ,а количество цветов ей вообще без разницы, ведь всё, что она делает, это резка строки адреса на блоки максимально возможной длины (<=255 символов) для создания адреса — типа Union'а, но в десятки/сотни раз быстрее
Создал отдельный файл, чтобы тебя ничего не отвлекало
Код
Option Explicit
Option Private Module
'====================================================================================================
Sub Tester()
Dim x, arr()
Dim t!, tt!, r&, i&
tt = Timer: t = Timer
ReDim arr(Rows.Count / 2 - 1): i = -1
For r = 2 To Rows.Count Step 2
i = i + 1: arr(i) = Cells(r, 1).Resize(1, 10).Address(0, 0, xlA1)
Next r
Debug.Print "Adr by bedvit:", Format$(Timer - t, "0.0 sec")
t = Timer
For Each x In FILE_RangesFromAddress(Join(arr, ","))
x.Interior.Color = vbYellow
Next x
Debug.Print "bedvit color:", Format$(Timer - t, "0.000 sec")
Debug.Print "Time total:", Format$(Timer - tt, "0.000 sec")
End Sub
'====================================================================================================
Function FILE_RangesFromAddress(ByVal txAdr$, Optional sh As Worksheet) As Range()
Dim arr() As Range
Dim l&, n&, i&, p&, m&
If sh Is Nothing Then Set sh = ActiveSheet
If InStr(txAdr, "$") Then txAdr = Replace$(txAdr, "$", "")
l = Len(txAdr): If l < 256 Then ReDim arr(0): arr(0) = txAdr: GoTo fin
m = l - 256
ReDim arr(l \ 200): n = -1
Do
i = InStrRev(txAdr, ",", p + 256)
n = n + 1: Set arr(n) = sh.Range(Mid$(txAdr, p + 1, i - p - 1))
p = i
If p > m Then
n = n + 1: Set arr(n) = sh.Range(Right$(txAdr, l - p))
ReDim Preserve arr(n): GoTo fin
End If
Loop
fin: FILE_RangesFromAddress = arr
End Function
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
обновил СС и добавил таблицу сравнения; все тесты, какие хотел, провёл; конкурентов по скорости пока нет Следующей темой будет выделение ячеек (на основании победившего варианта резки строк RangesFromAddress)
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Jack Famous написал: конкурентов по скорости пока нетСледующей темой будет выделение ячеек (на основании победившего варианта резки строк RangesFromAddress)
Конкурентов пока нет - 0,8 сек.
прочие аутсайдеры: bedvit Total: 5,089844 Adr by bedvit: 2,3 sec bedvit color: 2,863 sec Time total: 5,168 sec
Следующей темой будет выделение ячеек (на основании победившего варианта обработки ячеек XLLbuttonSelectCells)
Скрытый текст
Код
extern "C" __declspec(dllexport) int XLLbuttonSelectCells(wchar_t* param)
{
if (SDCED(0)) { return -1; }
long startTime = clock(); // начальное время
std::unique_ptr<XLOPER12, decltype(&xlAutoFree12X)>uPtr1(new XLOPER12{ 0, xltypeSRef }, &xlAutoFree12X); LPXLOPER12 res = uPtr1.get();
std::unique_ptr<XLOPER12, decltype(&xlAutoFree12X)>uPtr2(new XLOPER12, &xlAutoFree12X); LPXLOPER12 pxArray = uPtr2.get();
std::unique_ptr<XLOPER12, decltype(&xlAutoFree12X)>uPtr3(new XLOPER12, &xlAutoFree12X); LPXLOPER12 pArrayOut = uPtr3.get();
std::unique_ptr<XLOPER12, decltype(&xlAutoFree12X)>uPtr4(new XLOPER12, &xlAutoFree12X); LPXLOPER12 xlopValue = uPtr4.get();
if (Excel12X(xlSheetId, pArrayOut,0, 0)) {return -1; }
else {
pArrayOut->xltype = xltypeRef;
pArrayOut->val.mref.lpmref = new XLMREF12[65535];
pArrayOut->val.mref.lpmref->count = 0;
//pArrayOut->val.mref.lpmref->reftbl[0].colFirst
}
ULONGLONG iEnd = 1048576;
for (ULONGLONG i = 1; i < iEnd; i+=2) //со второй строки, через строку
{
if (pArrayOut->val.mref.lpmref->count >= 32767) {
if (Excel12X(xlcSelect, 0, 0, 1, pArrayOut)) { return -1; }
if (AutoWrapX(DISPATCH_PROPERTYPUT, 0, 0, 0, L"Selection.Interior.Color", 1, CComVariant(65535))) { return -1; }
pArrayOut->val.mref.lpmref->count=0;
}
pArrayOut->val.mref.lpmref->reftbl[pArrayOut->val.mref.lpmref->count].colFirst = 0;
pArrayOut->val.mref.lpmref->reftbl[pArrayOut->val.mref.lpmref->count].colLast = 9;
pArrayOut->val.mref.lpmref->reftbl[pArrayOut->val.mref.lpmref->count].rwFirst = i;
pArrayOut->val.mref.lpmref->reftbl[pArrayOut->val.mref.lpmref->count].rwLast = i;
pArrayOut->val.mref.lpmref->count++;
}
if (Excel12X(xlcSelect, 0, 0, 1, pArrayOut)) { return -1; }
if (AutoWrapX(DISPATCH_PROPERTYPUT, 0, 0, 0, L"Selection.Interior.Color", 1, CComVariant(65535))) { return -1; }
SDCED(1);
long endTime = clock(); // конечное время
MessageBox(hwndExcel, std::wstring(L"\nВремя выполнения, миллисекунд: " + std::to_wstring(endTime - startTime)).c_str(), bedvitXLL, MB_OK | MB_ICONINFORMATION);
return 0;
}
К сожалению очень не оптимизированный, т.к. пришлось подключить СОМ (функция AutoWrapX) - а это долго. Вот мой вариант сравнения, см. видео
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
bedvit: мой вариант спокойно соперничает с твои и обгоняет
на C++? На VBA решения будут?
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Я же выше выложил, не смотрел? Пост 11 На видео пост 14, видно что паритет, иногда выигрывает иногда проигрывает. На видео выигрывает (бывает что и проигрывает). Для универсально твой метод с хорошей скоростью, здесь соглашусь. Пили и развивай дальше
bedvit, мои 4,08 против твоих 4,7 - это выигрыш? К тому же это лучший вариант для твоего способа - то есть при увеличении цветов или шахматке он сильно проиграет
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
bedvit написал: мои 4,08 против твоих 4,7 - это выигрыш?
да мои 5.09 быстрее твоих 5.2 (ты видео смотрел?) Притом я думаю, что здесь паритет, а в связи с тем, что ты позиционирует свое решение, как универсальное, а я свое узкоспециализированное, твой вариант вполне интересен.
bedvit, не смотрел - у меня на работе нельзя Ты уклоняешься: даже в идеальных для твоего способа условиях, мы, можно сказать, наравне. Приближая примеры к жизни, от твоего способа придётся отказаться, т. к. фильтровать всё подряд не вариант, не говоря уже о том, что ты вставляешь данные в ячейки Есть идеи, куда пилить-то?)
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
bedvit, твои наработки в библиотеке не имеют конкурентов, но вот работать с ними не так просто. Например, на работе, регистрацию библы не пропустят - потому и извращаюсь, выжимая максимум)
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Теперь в серьезных аутсайдерах. Новое время: 0,08 сек. Более чем в 60 раз быстрее VBA.
Что доработано: 1.НЕ используется стандартный UNION и НЕ используется SpecialCells. Написал свою реализацию, которая на 2,6% дает больше блоков (Areas),что плохо, но работает на порядки! быстрее, что очень хорошо. Вот как выглядит результат 2.Используются стандартные функции C API для выбора нужного диапазона, определения последней ячейки 3.Создана функция поиска в данных ареалах, с учетом задаваемых условий сравнения пользователем (компаратора).
И как итог, проверка работоспособности:
Комментарии к числам на последнем рисунке: Выделено ячеек (весь лист) - 17 179 869 184 (17 млрд.) Найдено ячеек удовлетворяющих условию - 18 748 739 (всего 25 столбцов по 1 млн.ячеек=25 млн. ячеек) Создано Areas - 4 688 249 (моя, самописная UNION) Создано стеков (массив XLOPER12 (xltypeRef), по 32 767 Areas в каждом) - 144 Время выполнения: 8,3 секунды
За раз выделяется/закрашивается 1 стек (32 767 Areas), но пока через СОМ, через C API пока не удалось сделать быстрее (очень мало данных, материалов почти нет, по крупицам собираю)
чойта не с кем? А как же я?))) Владимир ZVI тоже в теме - я писал ему Ну то, что C выиграет в разы я не сомневался, так что поздравляю тебя с очередным крутым инструментом для своей библиотеки и найденным решением
Я так понимаю, что в VBA у меня конкурентов пока нет?
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
звучит, как общество жирдяев Жду его - отправь ссылку на группу прям
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Предложу решения по ускорению кода на VBA (с xll соперничать нету смысла и некорректно), но для начала немного декомпозиции:
Алгоритм можно разделить на 3 пункта (рассматривала решение Jack Famous - Time total: 3,270 sec):
Получение адресов нужных ячеек и формирование одномерного массива;
Формирование единой строки с адресами (через Join);
Блочная закраска нужных диапазонов.
Цитата
Важно: Данное решение и так достаточно хорошо отрабатывает, тем более данная операция в большинстве случаев будет требоваться максимум 1 раз! Поэтому ниже представленная оптимизация, по факту не требуется, и представлена чисто с целью предоставить альтернативное решение!
Предложение по оптимизации 1 пункта (Результат 0,3, взамен 1,6):
Скрытый текст
Этот вариант у меня отрабатывает за 1.6 сек. и это примерно половина от полного времени всего алгоритма:
Код
tt = Timer: t = Timer
ReDim arr(Rows.Count / 2 - 1): i = -1
For r = 2 To Rows.Count Step 2
i = i + 1: arr(i) = Cells(r, 1).Resize(1, 10).Address(0, 0, xlA1)
Next r
Debug.Print "Adr by bedvit:", Format$(Timer - t, "0.0 sec") ' 1.6
Минус данного метода - цикличное обращение к объектной модели Excel, поэтому, желательно найти решение для отработки без взаимодействия с объектной моделью Excel в цикле! Можем это сделать следующим образом:
Код
tt = Timer: t = Timer
ReDim arr(Rows.Count / 2 - 1): i = -1
'---------------------------------------------------------------------------------------'
' Для начала определим границы первого диапазона, который мы хотим закрасить
Start = Cells(2, 1).Resize(1, 10).Address(0, 0, xlA1)
' Далее выдёргиваем номер строки. Например("A2:J2") = 2 или ("A555:J555") = 555
For r = 1 To Len(Start)
If IsNumeric(Mid(Start, r, 1)) Then NeedNumber = Val(Mid(Start, r)): Exit For
Next
arr(0) = Start: i = 0
' Заполнение массива интересующими адресами с помощью Replace
For r = 4 To Rows.Count Step 2
i = i + 1: arr(i) = Replace(arr(i - 1), NeedNumber, r)
NeedNumber = r
Next r
'---------------------------------------------------------------------------------------'
Debug.Print "Adr by Anastasia:", Format$(Timer - t, "0.0 sec") ' 0.3
Сильно попрошу не критиковать, только сегодня накидала пример! Главное - это демонстрация принципа, который можно оптимизировать для своих нужд!
2 пункт и 3 пункт без оптимизации (P.S. К успеху шла, но не получилось, не фартануло!):
Скрытый текст
Функция FILE_RangesFromAddress отрабатывает у меня примерно за 0,38. Переписывать данное решение на мой взгляд не имеет смысла, т.к. основная дорогая операция - Set arr(n) = sh.Range...
Можно конечно сделать подобное решение с обработкой индексов массива безSet arr(n) = sh.Range) и оно будет быстрее (0,2 против 0,38):
Код
'---------------------------------------------------------------------------------------'
t = Timer
Dim LB&, UB&, Len_Temp&, ii&, Line$, j&, v$, tmp1$, iii&, y$, arr_tmp$()
Dim sh As Worksheet: Set sh = ActiveSheet
LB = LBound(arr, 1)
UB = UBound(arr, 1)
Dim arr2() As String: ReDim arr2(UB)
i = 0: ii = -1
ReDim arr_tmp(1 To 64)
For r = LB To UB
x = arr(r)
Len_Temp = Len_Temp + Len(x) + 1
If Len_Temp > 256 Then
ReDim Preserve arr_tmp(1 To iii - 1)
tmp1 = Join(arr_tmp, ",")
ii = ii + 1
arr2(ii) = tmp1
Len_Temp = Len(y) + 1
arr_tmp(1) = y
arr_tmp(2) = x
iii = 2
Else
iii = iii + 1
ReDim Preserve arr_tmp(1 To iii)
arr_tmp(iii) = x
y = x
End If
Next r
If Not Len_Temp = 0 Then
ReDim Preserve arr_tmp(1 To iii)
tmp1 = Join(arr_tmp, ",")
ii = ii + 1
arr2(ii) = tmp1
End If
ReDim Preserve arr2(ii)
Debug.Print "Adr by Anastasia:", Format$(Timer - t, "0.00 sec") ' 0.2
'---------------------------------------------------------------------------------------'
Но Пункт №3 вынуждает нас обратиться к объектной модели Excel, а цикл в таком виде отрабатывает медленнее (~ на 0,3 медленее):
Код
For Each x In arr2
Range(x).Interior.Color = vbYellow
Next x
Чем в таком, т.к. цикл ниже заранее формирует единый массив типа Range, а выше описанное решение генерирует Range непосредственно в цикле:
Код
For Each x In FILE_RangesFromAddress(Join(arr, ","))
x.Interior.Color = vbYellow
Next x
Соответственно выигрывая в производительности в пункте 2 (0,18 сек.), мы проигрываем больше в пункте 3 (0,3 сек.). Разница = 0,12 сек!
Итог: Шалость удалась только с пунктом №1 (Итоговое время упало до 2,023)! В остальных случаях оптимизация не имеет смысла, т.к. Jack Famous, уже, на мой взгляд, выжал максимум + идёт упор на объектную модель, где программисты на VBA особой власти не имеют (остается только перебирать реализованные методы Microsoft или пользовательские надстройки и библиотеки на сторонних языках, если основная цель - это максимальная производительность в вычислениях).
Aнaстaсия, здравствуйте! Спасибо за внимание к теме!
Цитата
Aнaстaсия: Предложение по оптимизации 1 пункта: Получение адресов нужных ячеек и формирование одномерного массива
ну, непосредственно к теме этот пункт как раз отношения не имеет, т.к. это подготовительный этап. Вот моя тема по сбору, но она очень замусорена… Ускорить получение адреса, можно, используя координаты 1ой (левой верхней ячейки) области и размер области. Строку адреса получаем вручную, получая литеры столбцов с помощью функций (в конце) из этой моей темы. Можно ещё протестировать ручное получение адреса R1C1 (там литеры столбцов не нужны), но, по моему, это медленнее в итоге будет…
P.S.: спойлеры использованы отлично! Им можно давать имена, если что, чтобы понимать, что они скрывают
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄