Этой темой открываю для себя новую рубрику тем — Тесты. Предлагаю делиться фишками и плюшками для ускорения/удобства/понятности работы в VBA Excel
Вот мой первый список тестов. Многое для меня было неожиданно и удивительно. Отдельно отмечу, что GoTo-переходы очень даже полезны бывают
КОД
Код
Option Explicit
Const delim$ = "—"
Const colorBad& = 10198015
Const colorGood& = 11534255
Dim dic As Object, arr, arr1, arr2, arr3, x, temp, txt$, i&, r&, c&, tm1!, tm2!, tm3!, tm4!, tm5!
'============================================================================================================
Sub Блок() 'Преимущество блока With…End With не очевидно.
arr = [_1mlnname].Value2
'-------------------------------------------
' Чуть лучше (~730 ms; <1%)
tm1 = Timer
With CreateObject("Scripting.Dictionary")
For Each x In arr
temp = .Item(x)
Next x
i = .Count: arr1 = .Keys
End With
tm1 = Timer - tm1: MsgBox i & delim & Format(1000 * tm1, "0 ms"): i = 0
'-------------------------------------------
' Чуть хуже (~735 ms)
tm2 = Timer: Set dic = CreateObject("Scripting.Dictionary")
For Each x In arr
temp = dic.Item(x)
Next x
i = dic.Count: arr1 = dic.Keys
tm2 = Timer - tm2: MsgBox i & delim & Format(1000 * tm2, "0 ms"): i = 0
'-------------------------------------------
Call MsgCompare(tm1, tm2)
End Sub
'============================================================================================================
Sub МассивИзДиапазонаБулевых() 'Сокрушительная победа ".Value2"
'-------------------------------------------
' Лучший (~70 ms; ~190%)
tm1 = Timer: arr1 = [_1mlnbool].Value2: tm1 = Timer - tm1: MsgBox Format(1000 * tm1, "0 ms")
'-------------------------------------------
' Худший (~200 ms)
tm2 = Timer: arr2 = [_1mlnbool].Value: tm2 = Timer - tm2: MsgBox Format(1000 * tm2, "0 ms")
'-------------------------------------------
Call MsgCompare(tm1, tm2)
End Sub
'============================================================================================================
Sub МассивИзДиапазонаСтрок() 'Не так хорошо, как казалось. Равны. Почему-то ".Value" на строках быстрее, чем на булевых…
'-------------------------------------------
' Чуть лучше (~175 ms; ~3%)
tm1 = Timer: arr1 = [_1mlnname].Value2: tm1 = Timer - tm1: MsgBox Format(1000 * tm1, "0 ms")
'-------------------------------------------
' Чуть хуже (~180 ms)
tm2 = Timer: arr2 = [_1mlnname].Value: tm2 = Timer - tm2: MsgBox Format(1000 * tm2, "0 ms")
'-------------------------------------------
Call MsgCompare(tm1, tm2)
End Sub
'============================================================================================================
Sub МассивМассивов() 'Полная победа Redim Preserve над элементами словаря в данном примере
Dim rng As Range, n&, rr&, cc%
Set rng = [_1mlnname]
arr = rng.Value2: rr = UBound(arr, 1): cc = UBound(arr, 2): n = rr * cc
'-------------------------------------------
' 1 место (5/40/2000/450)
tm1 = Timer
ReDim arr1(0 To n): ReDim arr2(0 To n): ReDim arr3(0 To 1)
For c = 1 To cc
For r = 1 To rr
x = arr(r, c)
If Len(x) And x <> "—" Then arr1(i) = x: arr2(i) = rng(r, c).Address: i = i + 1
Next r
Next c
ReDim Preserve arr1(i - 1): ReDim Preserve arr2(i - 1): arr3(0) = arr1: arr3(1) = arr2
txt = Join(arr3(0), delim): i = Len(txt)
tm1 = Timer - tm1: MsgBox i & delim & Format(1000 * tm1, "0 ms"): i = 0: txt = "": r = 0: c = 0: x = 0: arr1 = "": arr2 = "": arr3 = ""
'-------------------------------------------
' 2 место (15/450/42000/39000)
tm2 = Timer
With CreateObject("Scripting.Dictionary")
For c = 1 To cc
For r = 1 To rr
x = arr(r, c)
If Len(x) And x <> "—" Then .Item(rng(r, c).Address) = x
Next r
Next c
txt = Join(.Items, delim)
End With
i = Len(txt)
tm2 = Timer - tm2: MsgBox i & delim & Format(1000 * tm2, "0 ms"): i = 0: txt = "": r = 0: c = 0: x = 0: arr1 = "": arr2 = "": arr3 = ""
'-------------------------------------------
Call MsgCompare(tm1, tm2)
End Sub
'============================================================================================================
Sub ПереборСтрокиСтолбцы() 'Действительно, при стандартной (вертикальной) структуре данных, перебор сначала по строкам и только потом по столбцам чуть быстрее
Dim rr&, cc%, part%
arr = [_1mlnname].Value2: rr = UBound(arr, 1): cc = UBound(arr, 2)
'-------------------------------------------
' 1 место (~11700 ms; ~23%)
tm1 = Timer
For part = 1 To 1000 'цикл повторения для уточнения результата
For c = 1 To cc
For r = 1 To rr
i = i + 1
Next r
Next c
Next part
tm1 = Timer - tm1: MsgBox i & delim & Format(1000 * tm1, "0 ms"): i = 0: r = 0: c = 0: part = 0
'-------------------------------------------
' 2 место (~14400 ms)
tm2 = Timer
For part = 1 To 1000
For r = 1 To rr
For c = 1 To cc
i = i + 1
Next c
Next r
Next part
tm2 = Timer - tm2: MsgBox i & delim & Format(1000 * tm2, "0 ms"): i = 0: r = 0: c = 0: part = 0
'-------------------------------------------
Call MsgCompare(tm1, tm2)
End Sub
'============================================================================================================
Sub ПеременныеДляМассива() '"Преимущество переменной типа Variant" или "Как со старта сразу рвануть вперёд"
Dim arr0()
'-------------------------------------------
' Лучший (~180 ms; ~50%)
tm1 = Timer: arr = [_1mlnname].Value2: tm1 = Timer - tm1: MsgBox Format(1000 * tm1, "0 ms")
'-------------------------------------------
' Худший (~270 ms)
tm2 = Timer: arr0 = [_1mlnname].Value2: tm2 = Timer - tm2: MsgBox Format(1000 * tm2, "0 ms")
'-------------------------------------------
Call MsgCompare(tm1, tm2)
End Sub
'============================================================================================================
Sub ПоискКонкретногоЗначения() 'Где-то слышал о приемуществах StrComp. Не в этом примере…
arr = [_1mlnname].Value2: temp = "Александра"
'-------------------------------------------
' 1 место (~125 ms; ~16%)
tm1 = Timer
For Each x In arr
If x = temp Then i = i + 1
Next x
tm1 = Timer - tm1: MsgBox i & delim & Format(1000 * tm1, "0 ms"): i = 0
'-------------------------------------------
' 2 место (~145 ms)
tm2 = Timer
For Each x In arr
If StrComp(x, temp) = 0 Then i = i + 1
Next x
tm2 = Timer - tm2: MsgBox i & delim & Format(1000 * tm2, "0 ms"): i = 0
'-------------------------------------------
Call MsgCompare(tm1, tm2)
End Sub
'============================================================================================================
' Сказ о том, как Like InStr победил
'============================================================================================================
Sub ПоискНеточныйБезРегистра() 'Безоговорочная победа (~41%) Like
arr = [_1mlnname].Value2
'-------------------------------------------
' 1 место (~270 ms; ~41%)
tm1 = Timer: txt = "*ЕН*"
For Each x In arr
If UCase(x) Like txt Then i = i + 1
Next x
tm1 = Timer - tm1: MsgBox i & delim & Format(1000 * tm1, "0 ms"): i = 0
'-------------------------------------------
' 2 место (~380 ms)
tm2 = Timer: txt = "ен"
For Each x In arr
If InStr(1, x, txt, 1) Then i = i + 1
Next x
tm2 = Timer - tm2: MsgBox i & delim & Format(1000 * tm2, "0 ms"): i = 0
'-------------------------------------------
Call MsgCompare(tm1, tm2)
End Sub
'————————————————————————————————————————————————————————————————————————————————————————————————————————————
Sub ПоискНеточныйСРегистром() 'Чуть быстрее (~7%) оказался InStr
arr = [_1mlnname].Value2
'-------------------------------------------
' 1 место (~145 ms; ~7%)
tm1 = Timer: temp = "ен"
For Each x In arr
If InStr(x, temp) Then i = i + 1
Next x
tm1 = Timer - tm1: MsgBox i & delim & Format(1000 * tm1, "0 ms"): i = 0: temp = 0
'-------------------------------------------
' 2 место (~155 ms))
tm2 = Timer: temp = "ен"
For Each x In arr
If InStr(x, temp) > 0 Then i = i + 1 ' всего 1 коррекция и скорость падает на 7%
Next x
tm2 = Timer - tm2: MsgBox i & delim & Format(1000 * tm2, "0 ms"): i = 0: temp = 0
'-------------------------------------------
' 3 место (~160 ms)
tm3 = Timer: temp = "*ен*"
For Each x In arr
If x Like temp Then i = i + 1
Next x
tm3 = Timer - tm3: MsgBox i & delim & Format(1000 * tm3, "0 ms"): i = 0: temp = 0
'-------------------------------------------
Call MsgCompare(tm1, tm2)
End Sub
'============================================================================================================
Sub ПустыеВыделить() 'Получилось, что не только сбор ОБЩЕГО рассмотрен.
'-------------------------------------------
'Итак, если нужно реально ВЫДЕЛИТЬ большой диапазон (что само по себе очень медленно), то без метода, что на 1 месте просто не обойтись. Для сбора ОБЩЕГО диапазона рассматриваются только методы на 1 и 4 месте, но последний с треском провалился на наибольшем диапазоне "_1mlnName" (не дождался его за 15 минут, хотя метод на 1 месте сделал за 35 секунд).
'Если нужно производить манипуляции с этими ячейками на листе, но при этом нет необходимости их единовременного выделения, то на огромных объёмах ("_1mlnName") даже обычный цикл по ячейкам будет быстрее метода, что на 1 месте. Быстрее простого цикла, в этом случае, будет только комбинированый метод, что на 2 месте. Он же является наиболее универсальным и стабильным.
'Короче, как и всегда: под каждую задачу — своё решение, но плюсы и минусы каждого из них знать необходимо, чтобы применять соответствующие.
'-------------------------------------------
'Результаты тестов приведены в мс (округлённое среднее для 3х вычислений) для диапазонов ("_10kCity" / "_1mlnBool" / "_1mlnName")
'-------------------------------------------
Dim sh As Worksheet, rng As Range, gr As Range, cl As Range, col&, p As Byte
'Set rng = [_10kCity] 'По местам: (20/40/60/430)
'Set rng = [_1mlnBool] 'По местам: (800/820/4550/815)
Set rng = [_1mlnname] 'По местам: (35500/670/3250/провалено)
Set sh = ThisWorkbook.Worksheets(rng.Parent.Name): arr = rng.Value2
col = colorBad
'col = colorGood
'-------------------------------------------
' 1 место. Общий:(20/800/35500)
tm1 = Timer
With CreateObject("Scripting.Dictionary")
For r = 1 To UBound(arr, 1)
For c = 1 To UBound(arr, 2)
If Len(arr(r, c)) Then GoTo nx1 Else: i = i + 1: temp = .Item(rng(r, c).Address)
nx1:
Next c
Next r
txt = Replace$(Join(.Keys, ","), "$", "")
End With
If Len(txt) < 256 Then
Set gr = sh.Range(txt)
Else
p = InStrRev(Left$(txt, 255), ",")
Set gr = sh.Range(Left$(txt, p - 1))
txt = Mid$(txt, p + 1)
While Len(txt) > 255
p = InStrRev(Left$(txt, 255), ",")
Set gr = Union(gr, sh.Range(Left$(txt, p - 1)))
txt = Mid$(txt, p + 1)
Wend
Set gr = Union(gr, sh.Range(txt))
End If
gr.Interior.Color = col
tm1 = Timer - tm1: MsgBox i & delim & Format(1000 * tm1, "0 ms"): i = 0: txt = "": Set gr = Nothing
'-------------------------------------------
' 2 место. По одному:(40/820/670)
tm2 = Timer
For r = 1 To UBound(arr, 1)
For c = 1 To UBound(arr, 2)
If Len(arr(r, c)) Then GoTo nx2 Else: i = i + 1
rng(r, c).Interior.Color = col
nx2:
Next c
Next r
tm2 = Timer - tm2: MsgBox i & delim & Format(1000 * tm2, "0 ms"): i = 0: txt = "": Set gr = Nothing
'-------------------------------------------
' 3 место. По одному:(60/4550/3250)
tm3 = Timer
For Each cl In rng
If Len(cl) Then GoTo nx3 Else: i = i + 1: cl.Interior.Color = col
nx3:
Next cl
tm3 = Timer - tm3: MsgBox i & delim & Format(1000 * tm3, "0 ms"): i = 0: txt = "": Set gr = Nothing
'-------------------------------------------
' 4 место. Общий:(430/815/провалено)
tm4 = Timer
For r = 1 To UBound(arr, 1)
For c = 1 To UBound(arr, 2)
If Len(arr(r, c)) Then GoTo nx4 Else: i = i + 1
If gr Is Nothing Then Set gr = sh.Range(rng(r, c).Address) Else: Set gr = Application.Union(gr, sh.Range(rng(r, c).Address))
nx4:
Next c
Next r
gr.Interior.Color = col
tm4 = Timer - tm4: MsgBox i & delim & Format(1000 * tm4, "0 ms"): i = 0: txt = "": Set gr = Nothing
'-------------------------------------------
Call MsgCompare(tm1, tm2)
End Sub
'============================================================================================================
Sub ПустыеПоиск() 'Проверка на пустоту через длину строки действительно лучше, но от знака нужно избавиться
arr = [_1mlnname].Value2
'-------------------------------------------
' 1 место. Вне зачёта (~95 ms; ~5%). Не универсально, т.к. строки нулевой длины не считает пустыми. Несущественный выигрыш.
tm1 = Timer
For Each x In arr
If IsEmpty(x) Then i = i + 1
Next x
tm1 = Timer - tm1: MsgBox i & delim & Format(1000 * tm1, "0 ms"): i = 0
'-------------------------------------------
' 2 место (~100 ms)
tm2 = Timer
For Each x In arr
If Len(x) Then GoTo nx Else: i = i + 1 ' переход экономит время: уходим от "Len(x)<1"
nx:
Next x
tm2 = Timer - tm2: MsgBox i & delim & Format(1000 * tm2, "0 ms"): i = 0
'-------------------------------------------
' 3 место (~110 ms)
tm3 = Timer
For Each x In arr
If Len(x) < 1 Then i = i + 1 ' без перехода скорость сразу падает на 10%
Next x
tm3 = Timer - tm3: MsgBox i & delim & Format(1000 * tm3, "0 ms"): i = 0
'-------------------------------------------
' 4 место (~117 ms)
tm4 = Timer
For Each x In arr
If x = "" Then i = i + 1 ' или x = vbNullString — без разницы
Next x
tm4 = Timer - tm4: MsgBox i & delim & Format(1000 * tm4, "0 ms"): i = 0
'-------------------------------------------
Call MsgCompare(tm1, tm2)
End Sub
'============================================================================================================
Sub СтрокаСкоростная() 'Полная победа Redim Preserve над элементами словаря в данном примере
Dim rng As Range
'Set rng = [_10kcity] 'По местам: (5/15/25)
'Set rng = [_100kname] 'По местам: (40/450/500)
'Set rng = [_1mlnbool] 'По местам: (2000/42000/42000)
Set rng = [_1mlnname] 'По местам: (450/39000/39000)
arr = rng.Value2
'-------------------------------------------
' 1 место (5/40/2000/450)
tm1 = Timer
ReDim arr1(UBound(arr, 1) * UBound(arr, 2))
For Each x In arr
If Len(x) And x <> "—" Then arr1(i) = x: i = i + 1
Next x
ReDim Preserve arr1(i - 1): txt = Join(arr1, delim): i = Len(txt)
tm1 = Timer - tm1: MsgBox i & delim & Format(1000 * tm1, "0 ms"): i = 0: txt = "": arr1 = ""
'-------------------------------------------
' 2 место (15/450/42000/39000)
tm2 = Timer
With CreateObject("Scripting.Dictionary")
For Each x In arr
If Len(x) And x <> "—" Then .Item(i) = x: i = i + 1 'обычный счётчик стабильно и предсказуемо быстрее в качестве генератора уникальных ключей на малых и средних объёмах
Next x
txt = Join(.Items, delim)
End With
i = Len(txt)
tm2 = Timer - tm2: MsgBox i & delim & Format(1000 * tm2, "0 ms"): i = 0: txt = ""
'-------------------------------------------
' 3 место (25/500/42000/39000)
tm3 = Timer
With CreateObject("Scripting.Dictionary")
For Each x In arr
If Len(x) And x <> "—" Then .Item(.Count) = x
Next x
txt = Join(.Items, delim)
End With
i = Len(txt)
tm3 = Timer - tm3: MsgBox i & delim & Format(1000 * tm3, "0 ms"): i = 0: txt = ""
'-------------------------------------------
Call MsgCompare(tm1, tm2)
End Sub
'============================================================================================================
Sub СтрокаЧерезРазделитель()
arr = [_10kcity].Value2 'Так мало (10k), потому что на 100k разница уже около минуты, что — в 1000(!) раз медленнее
'-------------------------------------------
' Лучший (~20 ms; ~600%; ~x70)
tm1 = Timer
With CreateObject("Scripting.Dictionary")
For Each x In arr
.Item(.Count) = x
Next x
txt = Join(.Items, delim): i = Len(txt)
End With
tm1 = Timer - tm1: MsgBox i & delim & Format(1000 * tm1, "0 ms"): i = 0: txt = ""
'-------------------------------------------
' Худший (~140 ms)
tm2 = Timer
For Each x In arr
txt = txt & x & delim
Next x
i = Len(txt) - Len(delim): txt = Left$(txt, i)
tm2 = Timer - tm2: MsgBox i & delim & Format(1000 * tm2, "0 ms"): i = 0: txt = ""
'-------------------------------------------
Call MsgCompare(tm1, tm2)
End Sub
'============================================================================================================
Sub Уникальный() 'Хранение инфы ТОЛЬКО о ключах не так уж сильно экономит время
arr = [_1mlnname].Value2
'-------------------------------------------
' Чуть лучше (~730 ms; ~5%)
tm1 = Timer
With CreateObject("Scripting.Dictionary")
For Each x In arr
temp = .Item(x)
Next x
i = .Count
End With
tm1 = Timer - tm1: MsgBox i & delim & Format(1000 * tm1, "0 ms"): i = 0
'-------------------------------------------
' Чуть хуже (~760 ms)
tm2 = Timer
With CreateObject("Scripting.Dictionary")
For Each x In arr
.Item(x) = temp
Next x
i = .Count
End With
tm2 = Timer - tm2: MsgBox i & delim & Format(1000 * tm2, "0 ms"): i = 0
'-------------------------------------------
Call MsgCompare(tm1, tm2)
End Sub
'============================================================================================================
Sub Циклы() 'Тут я скорее всего напортачил, т.к. Do…Loop слабо знаю
arr = [_1mlnbool].Value2
'-------------------------------------------
' 1 место (~55 ms; ~113%). Некорректное сравнение т.к мы не можем ТОЛЬКО по индексу узнать адрес элемента в диапазоне
tm1 = Timer
For Each x In arr
i = i + 1 ' введён счётчик, если бы нам понадобился индекс элемента
temp = temp + x
Next x
tm1 = Timer - tm1: MsgBox temp & delim & Format(1000 * tm1, "0 ms"): temp = 0
'-------------------------------------------
' 2 место (~117 ms)
tm2 = Timer
For r = 1 To UBound(arr, 1)
For c = 1 To UBound(arr, 2)
temp = temp + arr(r, c)
Next c
Next r
tm2 = Timer - tm2: MsgBox temp & delim & Format(1000 * tm2, "0 ms"): temp = 0
'-------------------------------------------
' 3 место (~121 ms)
tm3 = Timer: r = 1
Do While r <= UBound(arr, 1)
c = 1
Do While c <= UBound(arr, 2)
temp = temp + arr(r, c)
c = c + 1
Loop
r = r + 1
Loop
tm3 = Timer - tm3: MsgBox temp & delim & Format(1000 * tm3, "0 ms"): temp = 0
'-------------------------------------------
Call MsgCompare(tm1, tm2)
End Sub
'============================================================================================================
Private Sub MsgCompare(FirstPlace!, SecondPlace!)
MsgBox "The difference on time between 2 best methods is " & Format(1000 * (tm2 - tm1), "0.00 ms") & vbLf & _
"The first is better than the second by " & Format((tm2 / tm1) - 1, "0%"), vbInformation, "ИТОГИ"
End Sub
Ссылка на тестовый стенд (файл 6,6 Мб из-за списков на листах)
UPD 27.09: 1. Добавлен макрос «ПустыеВыделить» В частности, формирование диапазона из строки адресов через запятую, если она длиннее 255 символов — по этой теме.
2. Добавлен макрос «СтрокаСкоростная» В нём подчёркнуто превосходство Redim Preserve одномерного массива над элементами словаря для создания текстовой строки по условию.
3. Добавлен макрос «МассивМассивов» Я научился создавать массив массивов — бывает очень удобно. В частности, если при одном цикле, нужно записывать, N видов информации, то для этого как нельзя лучше подходит функция, возвращающая массив, состоящий из N одномерных массивов. Это очень универсально тем, что любой из полученных массивов можно очень быстро преобразовать (Join) в текстовую строку и использовать её в качестве списка сравнения, используя супербыстрый метод без циклов. Прослеживается линейная зависимость. Создание массива, состоящего из 2 одномерных массивов, одинаковых по количеству элементов, занимает примерно в 2 раза больше времени, нежели создание одного из них (вроде очевидно, но всё же). Ну и да - словари тут опять капитально проигрывают, так что пока вижу смысл их использовать только для создания уникальных списков или там, где необходимо проверять по .Exist (что тоже надо тестить - я уже загорелся ).
4. Макрос «Перебор» заменён на «ПереборСтрокиСтолбцы» Действительно наблюдается совсем незначительное, но всё-таки стабильное (да и предсказуемое) преимущество при переборе стандартной вертикальной структуры от столбцов к строкам.
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
'Неожиданная сокрушительная победа Redim Presrve над Словарём в случае, если из массива нужно собрать новый массив по условию
Почитайте Автор: Стивенс, Род Название: Visual Basic. Готовые алгоритмы, чтобы понять почему
Цитата
'Где-то слышал о приемуществах StrComp. Не в этом примере…
Попробуйте сравнить с UCase$(x) = UCase$(temp) и StrComp(x, temp, vbTextCompare) = 0 Общее замечание сравнивать 95мск и 100мск фактически бессмысленно. Попробуйте один и тот же код прогнать несколькими запусками, включая после нескольких перезагрузок Excel и системы (естественно, дав отстояться) и найти стандартное отклонение.
Андрей VG написал: Почитайте Автор: Стивенс, Род Название: Visual Basic. Готовые алгоритмы, чтобы понять почему
Андрей, привет! Заинтриговал Jack Famous, когда-то делал сравнение словаря и коллекции, а так же до кучи Scripting.FileSystemObject и Dir (искал наиболее производительный алгоритм поиск файлов по маске, имени)
Код
Sub Test_Collection_vs_Dictionary() ' - что быстрее словарь или коллекция
Dim t, y As String, arr(100000, 1) As String, i As Long, x As Long, xEnd As Long, FileTemp As String
Dim Coll As Collection: Set Coll = New Collection
Dim Dict: Set Dict = CreateObject("Scripting.Dictionary")
Dim FSO: Set FSO = CreateObject("Scripting.FileSystemObject")
xEnd = 100000 'количество итераций
For x = 1 To xEnd 'МАССИВ для проверки
arr(x, 0) = x
arr(x, 1) = "\\0.0.0.0\work$\05_КД\05-04_КС\КАТАЛОГИ\тест\0009613%01-С8-01.jpg" & x
Next
t = Timer
For x = 1 To xEnd 'добавляем элементы
Coll.Add arr(x, 0), arr(x, 1)
Next
Debug.Print "Внесение данных, Collection.Add = " & Timer - t
t = Timer
For x = 1 To xEnd 'ищем существующие элементы
y = Coll.Item(arr(x, 1))
Next
Debug.Print "Поиск верных данных, Collection.Item = " & Timer - t
t = Timer
For x = 1 To xEnd 'ищем не существующие элементы
On Error Resume Next
Err = 0
y = Coll.Item("\\0.0.0.0\work$\05_КД\05-04_КС\КАТАЛОГИ\тест\0009613%01-С8-01.jpg")
If Err Then y = 0: On Error GoTo 0
Next
Debug.Print "Поиск не верных данных, Collection.Item = " & Timer - t
t = Timer
For x = 1 To xEnd 'добавляем элементы
Dict.Add arr(x, 1), arr(x, 0)
Next
Debug.Print "Внесение данных, Dictionary.Add = " & Timer - t
t = Timer
For x = 1 To xEnd 'ищем существующие элементы
y = Dict.Item(arr(x, 1))
Next
Debug.Print "Поиск верных данных, Dictionary.Item = " & Timer - t
t = Timer
For x = 1 To xEnd 'ищем не существующие элементы
y = Dict.Item("\\0.0.0.0\work$\05_КД\05-04_КС\КАТАЛОГИ\тест\0009613%01-С8-01.jpg")
Next
Debug.Print "Поиск не верных данных, Dictionary.Item = " & Timer - t
t = Timer
For x = 1 To xEnd 'проверяем есть ли ключ
y = Dict.Exists(arr(x, 1))
Next
Debug.Print "Проверяем есть ли ключ, Dictionary.Exists = " & Timer - t
t = Timer
For x = 1 To xEnd 'ищем существующие элементы
y = Coll.Item(arr(50000, 1))
Next
Debug.Print "Поиск одного и того же верного значения, Collection.Item = " & Timer - t
t = Timer
For x = 1 To xEnd 'ищем существующие элементы
y = Dict.Item(arr(50000, 1))
Next
Debug.Print "Поиск одного и того же верного значения, Dictionary.Item = " & Timer - t
t = Timer
For x = 1 To xEnd 'ищем существующие элементы
y = Dict.Exists(arr(50000, 1))
Next
Debug.Print "Проверяем есть ли ключ - одинаковый для всех итераций, Dictionary.Exists = " & Timer - t
t = Timer
For x = 1 To xEnd 'ищем в массиве
For i = 1 To xEnd
If arr(i, 1) = arr(35, 1) Then y = arr(35, 0): Exit For
Next
Next
Debug.Print "Поиск одного и того же верного значения МАССИВ (35й элемент) = " & Timer - t
FileTemp = "C:\Windows\system.ini"
t = Timer
For x = 1 To xEnd 'ищем файл
y = FSO.FileExists(FileTemp)
Next
Set FSO = Nothing
Debug.Print "Поиск одного и того же верного значения, FSO.FileExists = " & Timer - t
FileTemp = "C:\Windows\system.ini"
t = Timer
For x = 1 To xEnd 'ищем файл
y = Dir(FileTemp) <> ""
Next
Debug.Print "Поиск одного и того же верного значения, Dir = " & Timer - t
End Sub
Итого, время в секундах на 100 000 итераций - добавление, поиск текста примерно 70 символов: Внесение данных, Collection.Add = 1,06543 Поиск верных данных, Collection.Item = 0,3808594 Поиск не верных данных, Collection.Item = 0,4990234 Внесение данных, Dictionary.Add = 0,6176758 Поиск верных данных, Dictionary.Item = 0,5703125 Поиск не верных данных, Dictionary.Item = 0,07910156 Проверяем есть ли ключ, Dictionary.Exists = 0,6557617 Поиск одного и того же верного значения, Collection.Item = 0,4052734 Поиск одного и того же верного значения, Dictionary.Item = 0,3447266 Проверяем есть ли ключ - одинаковый для всех итераций, Dictionary.Exists = 0,4121094 Поиск одного и того же верного значения МАССИВ (35й элемент) = 0,3149414 Поиск одного и того же верного значения, FSO.FileExists = 5,554199 Поиск одного и того же верного значения, Dir = 7,03125
По массивам - при поиске со средним значением не более 35 элемента в массиве - поиск по массиву быстрее коллекции и словаря. т.е. при равномерной вероятности найти результат - это массив из 70-75 элементов (0-70). Потом проигрывает. Возможно при других условиях (неравномерного поиска или при проверке существует ли ключ Dictionary.Exists) можно дойти и до 100 элементов, здесь многое зависит от структуры данных)
Привет, Виталий. Да там по этой теме у Алексея всё проще. Он последовательно записывает в массив удовлетворяющие шаблону значения, а потом после завершения всех циклов - изменяет размер массива по числу этих значений. Со словарём пытается сделать тоже самое. Естественно, запись/чтение в массиве всегда быстрее чем в словаре или коллекции. А книжку упомянул, потому что там хорошо описан код для АВЛ-деревьев - собственно словаря и для хэш-таблиц - коллекции. Уже по объёму кода, обслуживающего чтение/запись, видно, что словарь и коллекция при использовании их в качестве массива последовательно нумерованных элементов (ключей) всегда медленнее массива на алгоритмах доступа к элементу по его номеру.
Доброго времени суток, Планетяне! Обновил описание темы…
Андрей VG, спасибо за книжку и замечания! Полностью согласен с "прогонами" и, в целом, качеством и точностью сравнений. bedvit, благодарю за тесты! Пытался задействовать в сравнении "продвинутые" коллекции, но не получилось к ним обратиться…
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Jack Famous написал: словари тут опять капитально проигрывают, так что пока вижу смысл их использовать только для создания уникальных списков
А если нужно создать массивуникальных, по какому нибудь признаку, массивов? Может Словари не сразу 'в топку'?
Цитата
Я научился создавать массив массивов
Попробуйте создать Словарь Массивов. Просто Ваше безапелляционное 'только' несколько удивило. . Для каждой задачи - свой инструмент В ЭТОЙ теме, на скорую руку...
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Sanja написал: Попробуйте создать Словарь Массивов.
И в чем проблема?
Код
Sub Словарь_Массивов()
Dim Dict As Object
Set Dict = CreateObject("Scripting.Dictionary")
Dim Arr, i&, a, s, d
For i = 1 To 3
Arr = Range("Мас" & i).Value
Dict("Мас" & i) = Arr
Next i
a = Dict("Мас1")
s = Dict("Мас2")
d = Dict("Мас3")
End Sub