Открою новый блок: Функционал C API Excel для VBA. Напрямую использовать не предусмотрено, поэтому буду делать функции-обертки. Что это дает и зачем это нужно? Дает кратный прирост скорости (в некоторых случаях). Нужно для максимальной производительности кода в Excel, использую не самый быстрый VBA. Минусы: -Определенные ограничения самого C API Excel -Нужна XLL (можно напилить самому или использовать стороннюю с таким функционалом) -Нужно время спеца (который будет этим заниматься) для подготовки функций-оберток
Будет интерес и время - посмотрим, что из этого может получится.
В качестве тестового примера реализовал функцию поиска на листе нужных данных. Функция: FindValuesXLL Аргументы (см.ниже код): 1.Нужный диапазон - Range ( у меня выделенное - Selection, можно любой Range, в т.ч. и несколько Areas) 2.Искомое значение (может быть и числом и текстом) 3.Параметр сравнения (1 -меньше искомого значения, 2 - равно, 4 - больше, 8 - содержит (для строк)) параметры можно смешивать через OR (к примеру "1 or 2" ). Можно будет добавить еще параметров сравнения, при взаимном интересе к теме. Возвращаемый результат: Range (до 32767 Areas, см. ниже особенности) Особенности: >Сейчас реализован результат - как максимальный стек из 32767 Areas, т.е. будет найдено не более 32767 отдельно стоящих прямоугольников (в прямоугольнике может быть любое количество ячеек). Если будет нужно больше - можно рассмотреть. >Функция автоматически объединяет соседние по вертикали блоки в один (оптимизация по количеству Areas) >Строки сравниваются с учетом регистра. Есть возможность сделать без учета, если будет интерес.
Код
Sub test()
Dim x
Set x = Run("FindValuesXLL", Selection, 1500, 1)
x.Select
End Sub
Результат поиска на примере одного из быстрейших вариантов на VBA Всего ячеек - 170 000 Найдено отдельно стоящих ячеек -127 450
PRDX time total: 2,703 sec FindValuesXLL: 0,020 sec
Итого разница боле чем в 100 раз.
Прошу тестировать: скачать xll, открыть или установить с помощью установщика или самому, написать нужный код в VBA.
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
bedvit, спасибо, но тоже не открывает)) через телефон опять придётся шаманить… Она сама регистрируется или как?
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
bedvit написал: Всего ячеек - 170 000 Найдено отдельно стоящих ячеек -127 450
Виталий, пожалуйста, поясните - как можно в диапазоне из 170000 ячеек сделать не смежных 12740 каких-то ячеек, определяемых по значениям? У меня лучше чем половина не выходит Опять же не совсем, видимо, понимаю суть задачи. Сделал пример для 8 столбцов и 21250 строк (170000 ячеек). На шахматке сбор диапазонов для раскрашивания на моём ноуте 0,09 секунды в коллекцию. Ну, пусть ваш компьютер в два раза медленнее. 0,18. То есть выигрыш всего около порядка, что является обычным отношением в скорости между С++ и VBA, а не двух порядков.
Пошла жара Андрей VG, здравствуйте и вам У вас заливка не до конца идёт - 21 179 строк по 4 ячейки = 84 716 ячеек вместо 85 000 (см. скрины)
Модуль «Generator»
Код
Option Explicit
'====================================================================================================
Sub GenerateDataset(Optional iRnd As Boolean)
Dim vOut(1 To 21250, 1 To 8) As Long
Dim i&, k&
For i = 1 To 8
For k = 1 To 21250
If iRnd Then
vOut(k, i) = CLng(100 * Rnd) Mod 2
Else
vOut(k, i) = (k + i) Mod 2
End If
Next k
Next i
Range("A1").Resize(21250, 8).Value = vOut
End Sub
'====================================================================================================
Модуль «AndrewVG»
Код
Option Explicit
'====================================================================================================
Private Type QueryType
hasMerge As Boolean
prevAddress As String
prevRow As Long
End Type
'====================================================================================================
Private Type QueryResultType
isMerged As Boolean
mergedAddress As String
End Type
'====================================================================================================
Public Sub AndrewVG()
Dim vData, i&, k&, colChar$, msg$
Dim query As QueryType, curAddress$, t!, tt!
Dim queryResult As QueryResultType, pItems As New Collection
tt = Timer
t = Timer
vData = Range("A1").Resize(21250, 8).Value
For i = 1 To 8
colChar = Chr$(64 + i)
query.hasMerge = False
query.prevAddress = ""
query.prevRow = -1
For k = 1 To 21250
If vData(k, i) = 1 Then
curAddress = colChar & k
queryResult = GetMerge(curAddress, k, query)
If Len(queryResult.mergedAddress) > 255 Then
pItems.Add query.prevAddress
query.hasMerge = False
query.prevAddress = curAddress
Else
query.hasMerge = queryResult.isMerged
query.prevAddress = queryResult.mergedAddress
End If
query.prevRow = k
End If
Next k
Next i
Debug.Print "Get adr:", Fix(1000 * (Timer - tt)), pItems.Count & " cells"
t = Timer
For Each vData In pItems
Range(vData).Interior.Color = vbYellow
Next vData
Debug.Print "Paint:", Fix(1000 * (Timer - t))
Debug.Print "Total:", Fix(1000 * (Timer - tt))
End Sub
'====================================================================================================
Private Function GetMerge(ByVal curAddress$, curRow&, ByRef query As QueryType) As QueryResultType
Dim result As QueryResultType, pos&
If curRow - query.prevRow = 1 Then
result.isMerged = True
If query.hasMerge Then
pos = InStrRev(query.prevAddress, ":")
result.mergedAddress = Mid$(query.prevAddress, 1, pos) & curAddress
Else
result.mergedAddress = query.prevAddress & ":" & curAddress
End If
Else
If query.prevAddress = "" Then
result.mergedAddress = curAddress
Else
result.mergedAddress = query.prevAddress & "," & curAddress
End If
End If
GetMerge = result
End Function
'====================================================================================================
Модуль «PRDX»
Код
Option Explicit
'====================================================================================================
Sub PaRADoX()
Dim rng As Range
Dim arr, arrAdr() As String
Dim t!, tt!, r&, rr&, c&, i&, fUniv As Boolean
tt = Timer
fUniv = True
t = Timer
Cells.Interior.ColorIndex = xlNone
Set rng = Range("A1").Resize(21250, 8)
arr = rng.Value2: i = -1
Debug.Print "Prepare:", Fix(1000 * (Timer - t))
t = Timer
If fUniv Then
ReDim arrAdr(UBound(arr, 1) * UBound(arr, 2) - 1)
For c = 1 To UBound(arr, 2)
For r = 1 To UBound(arr, 1)
If arr(r, c) = 1 Then i = i + 1: arrAdr(i) = rng(r, c).Address(0, 0, xlA1)
Next r
Next c
If i < UBound(arrAdr) Then ReDim Preserve arrAdr(i)
Else
ReDim arrAdr(84999)
For r = 1 To 21249 Step 2
i = i + 1: arrAdr(i) = "A" & r
i = i + 1: arrAdr(i) = "C" & r
i = i + 1: arrAdr(i) = "E" & r
i = i + 1: arrAdr(i) = "G" & r
rr = r + 1
i = i + 1: arrAdr(i) = "B" & rr
i = i + 1: arrAdr(i) = "D" & rr
i = i + 1: arrAdr(i) = "F" & rr
i = i + 1: arrAdr(i) = "H" & rr
Next r
End If
Debug.Print "Get adr:", Fix(1000 * (Timer - t)), i + 1 & " cells"
t = Timer
For Each arr In FILE_RangesFromAddress(Join(arrAdr, ","))
arr.Interior.Color = vbYellow
Next arr
Debug.Print "Paint:", Fix(1000 * (Timer - t))
Debug.Print "Total:", Fix(1000 * (Timer - tt))
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): 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
'====================================================================================================
Сравнение в сек
Андрей: сбор = ~0.1; заливка = ~0.3; ВСЕГО = ~0.4 Я: сбор (унив.) = ~0,2; заливка ~0,3; ВСЕГО: ~0,5 Если же применить не универсальный сбор по значению, а сделать отбор специально для теста, примерно как у Андрея, то сбор займёт всего 0,02 сек и и общее время составит 0,3 сек
Скрины
Со своей стороны просто использовал готовую функцию укрупнения диапазонов. При росте объёмов заливки должна выигрывать всё более заметно Полагаю, что для тестов закрашивания (тем более на VBA) больше подходит моя тема, а эта немного о другом
UPD:
Цитата
bedvit: суть немного в другом, FindValuesXLL выдает не адреса, а Range
вот именно. Учитываю огромную тормознутость Union'а даже при самом оптимальном его применении, твоя XLL с ростом объёмов выделения будет уделывать ЛЮБОЕ решение на VBA всё сильнее
А потом я напишу функцию укрупнения диапазонов за счёт объединения соседних ячеек и снова сравним
Цитата
bedvit: Query для меня темный ящик - не использовал, видимо зря, красиво
в решении Андрея нет ничего стороннего, кроме VBA (он просто 2 пользовательских типа ввёл) - грубо говоря, то же накопление адреса/стэка до 255 символов и после этого, перекладывание в коллекцию — как было у тебя (глобально), только по-другому (в подходе и деталях) Я же продолжаю настаивать что резать длинную строку на блоки по ~255 символов и быстрее и универсальнее (не нужно контролировать стэк при сборе адресов)
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
bedvit написал: Query для меня темный ящик - не использовал, видимо зря, красиво (единственно не до конца закрашивает, Андрей посмотри, пропустил кусочек )
Это да, поправил - теперь красит все. Можно и отказаться от пользовательского типа - перейти на приватные переменные уровня модуля, заодно и скорость формирования адресов где-то в полтора раза поднять - за счёт отсутствия передачи аргументов. Было 0,09375 = 2184 Стало 0,0625 = 2184 А вот отказ от коллекции в пользу массива к увеличению производительности не ведёт. Видимо, основное время тратиться в DefineMerge - там же и нужно оптимизацию делать - переходить на массив адресов вместо сцепки в prevAddress с отслеживанием числа символов и только в самом конце проводить сцепку - меньше перезаписей по памяти по идее должно быть.
Скрытый текст
Код
Private hasMerge As Boolean
Private prevAddress As String
Private prevRow As Long
Private isMerged As Boolean
Private mergedAddress As String
Private curAddress As String
Private curRow As Long
Public Sub DefineRangeAddressCollection()
Dim vData, i As Long, colChar As String
Dim t As Single
Dim pItems As New Collection
t = Timer
vData = Range("A1").Resize(21250, 8).Value
For i = 1 To 8
colChar = Chr$(64 + i)
hasMerge = False
prevAddress = ""
prevRow = -1
For curRow = 1 To 21250
If vData(curRow, i) = 1 Then
curAddress = colChar & curRow
DefineMerge
If Len(mergedAddress) > 255 Then
pItems.Add prevAddress
hasMerge = False
prevAddress = curAddress
Else
hasMerge = isMerged
prevAddress = mergedAddress
End If
prevRow = curRow
End If
Next
If prevAddress <> "" Then
pItems.Add prevAddress
End If
Next
Debug.Print Timer - t & " = " & pItems.Count
t = Timer
For Each vData In pItems
Range(vData).Interior.Color = vbYellow
Next
Debug.Print Timer - t
End Sub
Private Sub DefineMerge()
Dim pos As Long
If curRow - prevRow = 1 Then
isMerged = True
If hasMerge Then
pos = InStrRev(prevAddress, ":", Len(curAddress) - 1, vbBinaryCompare)
mergedAddress = Mid$(prevAddress, 1, pos) & curAddress
Else
mergedAddress = prevAddress & ":" & curAddress
End If
Else
isMerged = False
If prevAddress = "" Then
mergedAddress = curAddress
Else
mergedAddress = prevAddress & "," & curAddress
End If
End If
End Sub
Цитата
Jack Famous написал: Если же применить не универсальный сбор по значению, а сделать отбор специально для теста, примерно как у Андрея, то сбор займёт всего 0,02 сек
А можно тест такой провести?
Updated В Module3 реализовал подход через массив, получилось в два раза быстрее чем в подходе Module2 (там исправил непрокрас последних строк)
Андрей VG, если собирать адреса, как у вас (не обращаясь к адресу ячейки диапазона, а склеивая запомненную букву очередного столбца с очередной строкой — ввёл флаг fFast в оба модуля), то всё равно мой подход чуть-чуть (в пределах погрешности, но стабильно) быстрее (см. скрины), а преимуществ по-прежнему намного больше: • Удобно Не нужно считать стек и вообще что-либо ещё делать при сборе адресов • Универсально и просто Собрали адреса в массив по любым необходимым критериям и запустили заливку в цикле по укрупнённым диапазонам (результат функции) • Меньше кода Функция является самостоятельной и лежит в модуле типа "хранилище функций", то есть объём кода, написанного для неё можно не учитывать • Никаких публичных переменных и "лишнего" кода в основных процедурах Не является минусом, если переменные "лежат" в модуле с функцией и никого не трогают. Если же, мне нужно при каждом сборе адресов вводить эти переменные для работы, то это довольно неудобно, хоть и некритично Ну а, если при каждом сборе ещё нужно немало кода скопипастить для подсчёта стэка, то это совсем грустно…
Скрины
Модуль «AVG» (Модуль 3 с топовой скоростью)
Код
Option Explicit
'====================================================================================================
Private addressItems() As String, prevAddress$, mergedAddress$, curAddress$
Private prevRow&, curRow&, lastItemId&, itemCharLength&, colonPos&
Private hasMerge As Boolean, isMerged As Boolean
'====================================================================================================
Public Sub AVG()
Dim rng As Range
Dim vData, colChar$, t!, tt!, c&, fFast As Boolean
Dim pItems As New Collection
fFast = True ' ускоритель сбора адресов
Cells.Interior.ColorIndex = xlNone
Set rng = Range("A1:H21250")
vData = rng.Value
tt = Timer
t = Timer
For c = 1 To 8
If fFast Then colChar = Chr$(64 + c)
hasMerge = False
ReDim addressItems(1 To 85)
itemCharLength = 0
lastItemId = 0
prevRow = -1
For curRow = 1 To 21250
If vData(curRow, c) = 1 Then
If fFast Then
curAddress = colChar & curRow
Else
curAddress = rng(curRow, c).Address(0, 0, xlA1)
End If
DefineMerge
If itemCharLength + lastItemId - 1 > 255 Then
If isMerged Then
addressItems(lastItemId) = prevAddress
Else
lastItemId = lastItemId - 1
End If
ReDim Preserve addressItems(1 To lastItemId)
pItems.Add Join(addressItems, ",")
hasMerge = False
ReDim addressItems(1 To 85)
lastItemId = 1
addressItems(1) = curAddress
itemCharLength = Len(curAddress)
Else
hasMerge = isMerged
End If
prevRow = curRow
End If
Next curRow
If lastItemId > 0 Then
ReDim Preserve addressItems(1 To lastItemId)
pItems.Add Join(addressItems, ",")
End If
Next c
Debug.Print "Get adr:", Fix(1000 * (Timer - t))
t = Timer
For Each vData In pItems
Range(vData).Interior.Color = vbYellow
Next vData
Debug.Print "Paint:", Fix(1000 * (Timer - t))
Debug.Print "Total:", Fix(1000 * (Timer - tt)), pItems.Count & " blocks"
End Sub
'====================================================================================================
Private Sub DefineMerge()
If curRow - prevRow = 1 Then
isMerged = True
prevAddress = addressItems(lastItemId)
itemCharLength = itemCharLength - Len(prevAddress)
If hasMerge Then
colonPos = InStrRev(prevAddress, ":", Len(curAddress) - 1, vbBinaryCompare)
addressItems(lastItemId) = Mid$(prevAddress, 1, colonPos) & curAddress
Else
addressItems(lastItemId) = prevAddress & ":" & curAddress
End If
itemCharLength = itemCharLength + Len(addressItems(lastItemId))
Else
isMerged = False
itemCharLength = itemCharLength + Len(curAddress)
lastItemId = lastItemId + 1
addressItems(lastItemId) = curAddress
End If
End Sub
Модуль «PRDX»
Код
Option Explicit
'====================================================================================================
Sub PaRADoX()
Dim rng As Range
Dim arr, arrAdr() As String
Dim txCol$, t!, tt!, r&, rr&, c&, i&, fFast As Boolean
'fFast = True ' ускоритель сбора адресов
Cells.Interior.ColorIndex = xlNone
Set rng = Range("A1:H21250")
arr = rng.Value2: i = -1
tt = Timer
t = Timer
ReDim arrAdr(UBound(arr, 1) * UBound(arr, 2) - 1)
For c = 1 To UBound(arr, 2)
If fFast Then txCol = Chr$(64 + c)
For r = 1 To UBound(arr, 1)
If arr(r, c) = 1 Then
If fFast Then
i = i + 1: arrAdr(i) = txCol & r
Else
i = i + 1: arrAdr(i) = rng(r, c).Address(0, 0, xlA1)
End If
End If
Next r
Next c
If i < UBound(arrAdr) Then ReDim Preserve arrAdr(i)
Debug.Print "Get adr:", Fix(1000 * (Timer - t)), i + 1 & " cells"
t = Timer
For Each arr In FILE_RangesFromAddress(Join(arrAdr, ","))
arr.Interior.Color = vbYellow
Next arr
Debug.Print "Paint:", Fix(1000 * (Timer - t))
t = Timer - tt
i = UBound(FILE_RangesFromAddress(Join(arrAdr, ","))) + 1
Debug.Print "Total:", Fix(1000 * t), i & " blocks"
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): 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
сравнение скорости сбора и Join'а коллекции против массива проведу позже - не думаю, что выигрыш будет за коллекцией…
UPD: Сбор адресов у массива заметно быстрее, но не в разы (2,3 сек против 3,5 для 10 млн "An" [A1, A2 … A10 000 000]) Как махом сцепить все элементы или ключи коллекции, я не нашёл, так что сравнение даже не имеет смысла для моего подхода Массив сцепляет 10 млн адресов в строку за 1,5 сек
Код
Код
Option Explicit
'====================================================================================================
Sub ArrColl()
Dim arr(), coll As New Collection
Dim tx$, t!, i&, n&, fArr As Boolean
fArr = True
n = 10000000
t = Timer
If fArr Then ReDim arr(n - 1)
For i = 1 To n
If fArr Then
arr(i - 1) = "A" & i
Else
coll.Add "A" & i
End If
Next i
Debug.Print "Fill:", Fix(1000 * (Timer - t))
t = Timer
If fArr Then
tx = Join(arr, ",")
Else
' tx = Join(coll.items, ",")
End If
Debug.Print "Join:", Fix(1000 * (Timer - t))
End Sub
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
установщик кучу ошибок выдал (доллар в Environ не понравился, потом функцию UnloadF подсветил, а потом я его закрыл нахрен )
А если ручками положить надстройку в AddIns и подключить, нажав галочку, то вот такое получается
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
А ты точно той разрядности устанавливаешь, как и разрядность самого Excel? (такая ошибка возникает, если выбрана разная разрядность библиотеки и самого Excel).
Цитата
Jack Famous написал: установщик кучу ошибок выдал (доллар в Environ не понравился, потом функцию UnloadF
Это функционал самого VBA, а не моей библиотеки, поэтому думаю это какие-то библы подключенные с твоей стороны генерят эту ошибку. Вышли скриншот ошибки (и скриншот библиотек подключенных в References). Не подключена ли References ->microsoft scripting runtime (по умолчанию она выключена на обычных ПК)?
ёпстудэй, друг, так надо большими красными буквами писать, что речь про Excel, ведь по-дефолту это про винду Подключил ручками, всё работает. Подбор суммы вылетел с ошибкой при выводе максимально приближённого, но остальное потыкал - норм (кнопки + функции + BedvitCOM.VBA) У меня теперь снова есть мегашустрый сортер))) Спасибо!
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
достаточно написать в названии файла - BedvitXLL(Excelx86).xll вместо BedvitXLL(x86).xll Вот тогда трудно будет не увидеть — это я тебе как "dev to dev" говорю. Так юзвери намного лучше воспринимают
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
ты бы лучше поставил полноценный Excel x64, а не половинку х32. И проблем было бы значительно меньше (не только с подключение библы), это я тебе как "dev to dev" говорю.
bedvit: ты бы лучше поставил полноценный Excel x64
мне тут вагон бумаги перевести на согласования надо для этого + есть вероятность, что у сотрудника будет "половинка" стоять и то, что у меня ошибок не вызывает, у него вызовет (например, взять в массив/память большой кусок с листа) А так, у меня запорожец и у него москвич - плюс-минус то на то и выходит. Вот такая вот "совместимость"
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
bedvit написал: Вышли скриншот ошибки (и скриншот библиотек подключенных в References). Не подключена ли References ->microsoft scripting runtime (по умолчанию она выключена на обычных ПК)?
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Поэтому у тебя и ошибка вылетает, у меня везде позднее связывание в установщике, а у тебя ранее, я так понял они не дружат. Зачем тебе столько, это же не переносимо? или ты не пилишь под пользователя конечные разработки? У меня вот сколько (стандарт при установке Офиса)
bedvit, в надстройке у меня всё подключено, потому что раннее быстрее и удобнее. Надо обходить
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
19/05/2021 Новый функционал: Быстрое изменение размерности массива. Сейчас поддерживается из одномерного в двухмерный с 1м столбцом, и наоборот.
Код
Sub ReDimArray()
Dim r As BedvitCOM.VBA: Set r = New BedvitCOM.VBA 'раннее связывание
Dim t, arr, i
arr = [a1:a1000000]
t = Timer
For i = 1 To 1000000
r.ReDimArray arr 'в одномерный (нижняя граница = 0 - по умолчанию)
r.ReDimArray arr, 2, , 1, , 1 'в двухмерный с 1м столбцом, нижние границы измерений = 1
Next
Debug.Print "bVBA.ReDimArray: " & Timer - t & " sec."
End Sub
Преобразование массива 1 млн. элементов в одномерный и далее в двухмерный (2 преобразования за цикл) - 1 млн. раз = 1,45 сек.
ReDimArray (параметры) 1. Массив (одно или двухмерный) для преобразования (обязательный параметр, остальные нет) 2. Количество нужных измерений (сейчас 1-2, по умолчанию = 1) 3. Количество элементов в 1м измерении (по умолчанию = все элементы) 4. Нижняя граница в 1м измерении (по умолчанию = 0) 5. Количество элементов в 2м измерении (по умолчанию = все элементы) 6. Нижняя граница в 2м измерении (по умолчанию = 0)
Была идея реализации быстрого аналога ReDim Preserve, с возможностью изменений любого из 5 измерений ( а не только последнего), пока остановился на 2х за отсутствием понимание нужно ли это.
реализованный функционал позволяет быстро передавать одномерные массивы на лист Excel и получать обратно (одномерные).
Option Explicit
Option Private Module
'====================================================================================================
Sub Tester()
Dim BedVit As New BedvitCOM.VBA
Dim x, tmp(), arr1x(), arr2x()
Dim t!, nEl&, nCyc&, n&, fText As Boolean
fText = False: nEl = 10: nCyc = 1000000
Debug.Print "TextData = " & fText, "Elements: " & Format$(nEl, "#,##0"), "Cycles: " & Format$(nCyc, "#,##0")
t = Timer
ReDim arr1x(nEl - 1)
For n = 1 To nEl
If fText Then
arr1x(n - 1) = "_" & Format$(n, "0000000")
Else
arr1x(n - 1) = n
End If
Next n
n = 1000 * (Timer - t): Debug.Print "FillArray", n, LBound(arr1x), UBound(arr1x) & vbLf
t = Timer
For n = 1 To nCyc
arr2x = arr1x
Arr1xTo2x arr2x
Next n
n = 1000 * (Timer - t): Debug.Print "VBA 1xTo2x", n, LBound(arr2x, 1), UBound(arr2x, 1), LBound(arr2x, 2), UBound(arr2x, 2)
t = Timer
For n = 1 To nCyc
x = arr1x
BedVit.ReDimArray x, 2, , 1, , 1
Next n
n = 1000 * (Timer - t): Debug.Print "BedVit 1xTo2x", n, LBound(x, 1), UBound(x, 1), LBound(x, 2), UBound(x, 2) & vbLf
arr2x = x
t = Timer
For n = 1 To nCyc
arr1x = arr2x
Arr2xTo1x arr1x
Next n
n = 1000 * (Timer - t): Debug.Print "VBA 2xTo1x", n, LBound(arr1x), UBound(arr1x)
t = Timer
For n = 1 To nCyc
x = arr2x
BedVit.ReDimArray x
Next n
n = 1000 * (Timer - t): Debug.Print "BedVit 1xTo2x", n, LBound(x), UBound(x)
End Sub
'====================================================================================================
Private Sub Arr1xTo2x(arr1x())
Dim arr2x(), r&
ReDim arr2x(1 To UBound(arr1x) + 1, 1 To 1)
For r = 1 To UBound(arr2x, 1)
arr2x(r, 1) = arr1x(r - 1)
Next r
arr1x = arr2x
End Sub
'====================================================================================================
Private Sub Arr2xTo1x(arr2x())
Dim arr1x(), i&
ReDim arr1x(UBound(arr2x, 1) - 1)
For i = 0 To UBound(arr1x)
arr1x(i) = arr2x(i + 1, 1)
Next i
arr2x = arr1x
End Sub
'====================================================================================================
Вывод: разница хорошая, стабильная, можно спокойно использовать вместо штатного преобразования, но дело в том, что я не могу припомнить, чтобы мне нужно было в цикле делать подобные преобразования
Параметры: нужен всего один - массив. Если передан одномерный (0 To N-1), то перегнать в двумерный (1 To N, 1 To 1) и наоборот Название тоже лучше не такое, а что-то вроде Array1x2xTransform()
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Привет! У тебя неправильный тест (ты добавляешь присваивание массива в цикле к общему времени, это лишнее) Результаты: bVBA.ReDimArray: 3,9 ms. VBA: 182 066,4 ms.
Разница боюсь даже писать 46 тыс. раз! (это так и есть, потому как у меня нет выделения памяти под новый массив, и элементы не копируются), только меняются указатели. Тест прикладываю. На всякий случай код:
Код
Option Explicit
Option Private Module
Sub TestBedvit()
Dim r As BedvitCOM.VBA: Set r = New BedvitCOM.VBA
Dim t, arr, i
[a1:a1000000] = 1
arr = [a1:a1000000]
t = Timer
For i = 1 To 1000
r.ReDimArray arr
r.ReDimArray arr, 2, , 1, , 1
Next
Debug.Print "bVBA.ReDimArray: " & (Timer - t) * 1000 & " ms."
For i = 1 To 1000
Arr2xTo1x arr
Arr1xTo2x arr
Next
Debug.Print "VBA: " & (Timer - t) * 1000 & " ms."
End Sub
'====================================================================================================
Sub Tester()
Dim BedVit As New BedvitCOM.VBA
Dim x, tmp(), arr1x(), arr2x()
Dim t!, nEl&, nCyc&, n&, fText As Boolean
fText = False: nEl = 10: nCyc = 1000000
Debug.Print "TextData = " & fText, "Elements: " & Format$(nEl, "#,##0"), "Cycles: " & Format$(nCyc, "#,##0")
t = Timer
ReDim arr1x(nEl - 1)
For n = 1 To nEl
If fText Then
arr1x(n - 1) = "_" & Format$(n, "0000000")
Else
arr1x(n - 1) = n
End If
Next n
n = 1000 * (Timer - t): Debug.Print "FillArray", n, LBound(arr1x), UBound(arr1x) & vbLf
t = Timer
For n = 1 To nCyc
arr2x = arr1x
Arr1xTo2x arr2x
Next n
n = 1000 * (Timer - t): Debug.Print "VBA 1xTo2x", n, LBound(arr2x, 1), UBound(arr2x, 1), LBound(arr2x, 2), UBound(arr2x, 2)
t = Timer
For n = 1 To nCyc
x = arr1x
BedVit.ReDimArray x, 2, , 1, , 1
Next n
n = 1000 * (Timer - t): Debug.Print "BedVit 1xTo2x", n, LBound(x, 1), UBound(x, 1), LBound(x, 2), UBound(x, 2) & vbLf
arr2x = x
t = Timer
For n = 1 To nCyc
arr1x = arr2x
Arr2xTo1x arr1x
Next n
n = 1000 * (Timer - t): Debug.Print "VBA 2xTo1x", n, LBound(arr1x), UBound(arr1x)
t = Timer
For n = 1 To nCyc
x = arr2x
BedVit.ReDimArray x
Next n
n = 1000 * (Timer - t): Debug.Print "BedVit 1xTo2x", n, LBound(x), UBound(x)
End Sub
'====================================================================================================
Private Sub Arr1xTo2x(arr1x)
Dim arr2x(), r&
ReDim arr2x(1 To UBound(arr1x) + 1, 1 To 1)
For r = 1 To UBound(arr2x, 1)
arr2x(r, 1) = arr1x(r - 1)
Next r
arr1x = arr2x
End Sub
'====================================================================================================
Private Sub Arr2xTo1x(arr2x)
Dim arr1x(), i&
ReDim arr1x(UBound(arr2x, 1) - 1)
For i = 0 To UBound(arr1x)
arr1x(i) = arr2x(i + 1, 1)
Next i
arr2x = arr1x
End Sub
'====================================================================================================
ну у меня скромнее, но всё-равно от 500 до нескольких тысяч раза (не 3 раза, конечно) Пару раз твоё время даже не измерилось (где 1 стоит), так что может там разница и выше 3 тысяч раз
Новый отчёт
Таблица сравнения (где 1мс стоит, там на самом деле 0, но нужно было как-то сравнить)
Код
Код
Option Explicit
Option Private Module
'====================================================================================================
Sub Tester()
Dim BedVit As New BedvitCOM.VBA
Dim arrV, arrA()
Dim t!, nEl&, nCyc&, n&, fText As Boolean
fText = True: nEl = 1000000: nCyc = 10
Debug.Print "TextData = " & fText, "Elements: " & Format$(nEl, "#,##0"), "Cycles: " & Format$(nCyc, "#,##0")
t = Timer
ReDim arrA(nEl - 1)
For n = 1 To nEl
If fText Then
arrA(n - 1) = "_" & Format$(n, "0000000")
Else
arrA(n - 1) = n
End If
Next n
n = 1000 * (Timer - t): Debug.Print "FillArray", n, LBound(arrA), UBound(arrA)
t = Timer
For n = 1 To nCyc
Arr1xTo2x arrA
Arr2xTo1x arrA
Next n
n = 1000 * (Timer - t): Debug.Print "VBA", n, LBound(arrA), UBound(arrA)
arrV = arrA
t = Timer
For n = 1 To nCyc
BedVit.ReDimArray arrV, 2, , 1, , 1
BedVit.ReDimArray arrV
Next n
n = 1000 * (Timer - t): Debug.Print "BedVit", n, LBound(arrV), UBound(arrV)
End Sub
'====================================================================================================
Private Sub Arr1xTo2x(arr1x())
Dim arr2x(), r&
ReDim arr2x(1 To UBound(arr1x) + 1, 1 To 1)
For r = 1 To UBound(arr2x, 1)
arr2x(r, 1) = arr1x(r - 1)
Next r
arr1x = arr2x
End Sub
'====================================================================================================
Private Sub Arr2xTo1x(arr2x())
Dim arr1x(), i&
ReDim arr1x(UBound(arr2x, 1) - 1)
For i = 0 To UBound(arr1x)
arr1x(i) = arr2x(i + 1, 1)
Next i
arr2x = arr1x
End Sub
'====================================================================================================
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Чем больше элементов и длиннее строка, тем у меня будет быстрее работать, за счет того, что не копируются данные (другими словами - больше данных, больше разрыв во времени). в 3 тыс. раз тоже неплохо Нижняя граница очень легко меняется, просто проставить = 1.
04/08/2021 новый FindValuesXLL - теперь поиск любого количества ячеек (начиная с версии XLL: 2.0.1.9) т.к. Excel С API не позволяет передать стек более 32767 Areas, создаем массив стеков и смотрим поэлементно. Для этого добавил режим (mode): 'mode=-1 (ищем ячейки, создаем массив и выводим количество найденных ячеек), mode=0 (выводим количество стеков с результатом), mode>0 (выводим результат под порядковым номером стека, начиная с 1) Заполняем массив mode=-1, остальные режимы - только вывод информации из статистического массива стеков
Код
Код
Sub testFindValuesXLL()
Dim result, resultCount, stekCount, stek, t
'Поиск результата mode=-1, остальные режимы - только вывод информации из статистического массива стеков
t = Timer
resultCount = Run("FindValuesXLL", ActiveSheet.UsedRange, 1, 2, -1) 'mode=-1(количество найденных ячеек), mode=0(количество стеков с результатом), mode>0 (порядковый номер стека, начало с 1)
stekCount = Run("FindValuesXLL", ActiveSheet.UsedRange, 1, 2, 0)
For stek = 1 To stekCount
Set result = Run("FindValuesXLL", ActiveSheet.UsedRange, 1, 2, stek)
'result.Interior.Color = 65535 ' закрасим найденные
'Debug.Print result.Count 'количество ячеек в текущем стеке
'result.Select 'выделим все ячейки в стеке
Next
Debug.Print resultCount, stekCount
Debug.Print "Time: " & Timer - t
End Sub
результат: поиск 1,25 млн.ячеек из 2,5 млн. = 0,28 сек.
говорил раньше, повторю - по названию переменной должно быть интуитивно понятно, что она делает, а эти "моды" — просто кошмар для любого, кто не ты
Подумай над своим аналогом функции округления. Непаханное поле
=Round(iVal, Optional Dig&, Optional UpDownBank$) Dig — до скольки знаков после запятой округлять (количество разрядов). Должны поддерживаться отрицательные значения (как в ОКРУГЛ) - для округления до десятков, сотен и т.д. UpDownBank=""— обычное математическое округление (по-умолчанию) UpDownBank="up"— округление вверх UpDownBank="down"— округление вниз UpDownBank="bank"— банковское округление
Самый быстрый на VBA - ZVI, но там только обычное математическое округление (я так понял RounUp так и не был допилен)
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄