В процессе ускорения своих макросов столкнулся с невероятной эффективностью проверки строки по маске и создал тему, чтобы подробно разобрать вопрос и оттестировать основные моменты для понимания Тестировать буду на реальной задаче, слегка упрощённой для теста: Преобразовать латиницу в похожую кириллицу
Зачем проверять строку?
Строку (или число) проверяют для того, чтобы что-то в ней найти (сюрприз) — в данной же теме проверка строки будет рассматриваться в качестве "фильтра" строк, не нуждающихся в обработке. Проще говоря: если обработка строки занимает в разы больше времени, чем её проверка (а, как правило, так и есть) + мы не уверены на 100%, что все строки нуждаются в обработке, значит имеет смысл очень быстро ПРОВЕРИТЬ строку и ПРОПУСТИТЬ её, если не подходит. Так можно очень сильно ускориться Чем больше строк будет пропущено и чем сложнее (больше времени) обработка строки — тем больше будет выигрыш во времени (прирост скорости)
Этап №1. Сравнение разных масок на разных строках (присутствует вывод прогресса в статусбар)
Таблица с результатами (1 млн прогонов для каждой из 30ти комбинаций)
Выводы
1. Если символы в строке есть, то, чем ближе они к началу, тем быстрее будет проверка (как в случае с InStr), а самая долгая она - если символов нет 2. Как ни странно, но целый диапазон латиницы в маске быстрее маски из только проверяемых символов
Этап №2. InStr сильно ускоряет Replace, а вместе с Like получается ещё быстрее
Скрин
Вывод:
также, как мы проверяем строку на наличие/отсутствие СПИСКА СИМВОЛОВ, необходимо проверять и наличие самого СИМВОЛА перед его заменой
Этап №3. Большой сравнительный тест необходимости проверки по маске
Таблица с результатами (100 тыс прогонов для каждой из 20ти комбинаций)
Выводы:
Несмотря на то, что проверка отсеяла всего лишь 20% строк (для 80% только отняла время) и список символов для замены очень короткий, время работы замены проверкой на 5,5% меньше, чем без неё Так получается из-за того, что отсев даёт прирост скорости на 20% в сотни и тысячи раз больше, чем её потеря на 80%
Очевидно, что с ростом количества символов для поиска и замены и/или количества строк, НЕ НУЖДАЮЩИХСЯ в замене, эффективность маски будет только возрастать, т.к. её замедление несоизмеримо меньше, чем увеличение цикла по символам для каждой строки
Коды
Tester
Код
Option Explicit
Option Private Module
'===========================================================================================
Sub MasksAndStrings()
Dim arrMask(), arrWhere(), arrOut() As Double
Dim txWhere$, txMask$, t!, cyc&, n&, r&, c&, flag As Boolean
arrMask = Array(psMaskFull, psMaskRange, psMaskExact)
arrWhere = Array(psWhereShortNo, psWhereShortFew, psWhereShortHalf, psWhereShortMany, psWhereShortAll, psWhereLongNo, psWhereLongFew, psWhereLongHalf, psWhereLongMany, psWhereLongAll)
ReDim arrOut(1 To UBound(arrWhere) + 1, 1 To UBound(arrMask) + 1)
For c = 1 To UBound(arrMask) + 1
For r = 1 To UBound(arrWhere) + 1
txWhere = UCase$(arrWhere(r - 1))
txMask = arrMask(c - 1)
t = Timer
For cyc = 1 To 1000000
flag = txWhere Like txMask
Next cyc
arrOut(r, c) = Timer - t
n = n + 1: Application.StatusBar = n & " out of " & UBound(arrOut, 1) * UBound(arrOut, 2) & ". Mask «" & txMask & "»": DoEvents
Next r
Next c
Application.StatusBar = False
shLike.Cells(4, 3).Resize(UBound(arrOut, 1), UBound(arrOut, 2)).Value2 = arrOut
Application.Calculate
End Sub
'===========================================================================================
Sub EasyTest()
Dim x, arrF, arrR, arrW()
Dim tx$, lat$, t!, n&, nMax&, i&, flag As Boolean
nMax = 1000000
arrF = Split(psSymEn)
arrR = Split(psSymRu)
arrW = Array(UCase$(psWhereShortHalf))
rep: lat = IIf(flag, "NO Lat", "Have Lat")
t = Timer
' Replace
For n = 1 To nMax
For Each x In arrW
For i = 0 To UBound(arrF)
tx = Replace(x, arrF(i), arrR(i))
Next i
Next x
Next n
Debug.Print "R", Timer - t, lat: DoEvents: t = Timer
' InStr + Replace
For n = 1 To nMax
For Each x In arrW
For i = 0 To UBound(arrF)
If InStr(x, arrF(i)) Then tx = Replace(x, arrF(i), arrR(i))
Next i
Next x
Next n
Debug.Print "IR", Timer - t, lat: DoEvents: t = Timer
' Like + InStr + Replace
For n = 1 To nMax
For Each x In arrW
If x Like psMaskFull Then
For i = 0 To UBound(arrF)
If InStr(x, arrF(i)) Then tx = Replace(x, arrF(i), arrR(i))
Next i
End If
Next x
Next n
Debug.Print "MIR", Timer - t, lat: DoEvents: t = Timer
If flag Then Exit Sub
flag = True: arrW = Array(UCase$(psWhereShortHalf), UCase$(psWhereShortNo)): GoTo rep
End Sub
'===========================================================================================
Sub HardTest()
Dim arrF, arrR, arrW(), arrOut() As Double
Dim tx$, where$, t!, n&, nMax&, w&, i&
nMax = 100000
arrF = Split(psSymEn)
arrR = Split(psSymRu)
arrW = Array(psWhereShortNo, psWhereShortFew, psWhereShortHalf, psWhereShortMany, psWhereShortAll, psWhereLongNo, psWhereLongFew, psWhereLongHalf, psWhereLongMany, psWhereLongAll)
ReDim arrOut(1 To UBound(arrW) + 1, 1 To 2)
For w = 0 To UBound(arrW)
where = UCase$(arrW(w))
Application.StatusBar = w + 1 & " out of " & UBound(arrOut, 1): DoEvents
t = Timer
For n = 1 To nMax
For i = 0 To UBound(arrF)
If InStr(where, arrF(i)) Then tx = Replace(where, arrF(i), arrR(i))
Next i
Next n
arrOut(w + 1, 1) = Timer - t
t = Timer
For n = 1 To nMax
If where Like psMaskFull Then
For i = 0 To UBound(arrF)
If InStr(where, arrF(i)) Then tx = Replace(where, arrF(i), arrR(i))
Next i
End If
Next n
arrOut(w + 1, 2) = Timer - t
Next w
Application.StatusBar = False
shHard.Cells(4, 3).Resize(UBound(arrOut, 1), UBound(arrOut, 2)).Value2 = arrOut
Application.Calculate
End Sub
'===========================================================================================
'===========================================================================================
Work
Код
Option Explicit
Option Private Module
'===========================================================================================
Public Const psSymEn$ = "A B C E H K M O P T X Y", psSymRu$ = "А В С Е Н К М О Р Т Х У"
Public Const psMaskFull$ = "*[A-Z]*", psMaskRange$ = "*[A-EHK-PTXY]*", psMaskExact$ = "*[ABCEHKMOPTXY]*"
Public Const psWhereName$ = "ShortNo ShortFew ShortHalf ShortMany ShortAll LongNo LongFew LongHalf LongMany LongAll"
Public Const psWhereShortNo = "эта короткая строка ПОЛНОСТЬЮ состоит из нашей Кириллицы"
Public Const psWhereLongNo = "Подокезавр - это род целофизоидных динозавров, которые жили на территории современной восточной части Соединенных Штатов в раннеюрский период между 201 и 190 миллионами лет назад. Его единственная известная окаменелость была обнаружена геологом Миньоном Талботом недалеко от горы Холиок, штат Массачусетс, в 1910 году."
Public Const psWhereShortFew = "эта короткая строка FULLY состоит из нашей Кириллицы"
Public Const psWhereLongFew = "Подокезавр - это род целофизоидных динозавров, которые жили на территории современной восточной части Соединенных Штатов в раннеюрский период между 201 и 190 миллионами лет назад. Его единственная известная окаменелость была обнаружена геологом Mignon Talbot недалеко от горы Холиок, штат Massachusetts, в 1910 году."
Public Const psWhereShortHalf = "эта короткая строка consists FULLY of Latin alphabet"
Public Const psWhereLongHalf = "Подокезавр - это род целофизоидных динозавров, которые жили на территории современной восточной части Соединенных Штатов в раннеюрский период между 201 и 190 миллионами лет назад. Its only known fossil was discovered by the geologist Mignon Talbot near Mount Holyoke, Massachusetts, in 1910. Some text to fill same len"
Public Const psWhereShortMany = "эта short String consists FULLY of Latin alphabet"
Public Const psWhereLongMany = "Подокезавр - это род целофизоидных динозавров, that lived in what is now the eastern United States during the Early Jurassic Period between 201 and 190 million years ago. Its only known fossil was discovered by the geologist Mignon Talbot near Mount Holyoke, Massachusetts, in 1910. Some text to fill same len"
Public Const psWhereShortAll = "this short String consists FULLY of Latin alphabet"
Public Const psWhereLongAll = "Podokesaurus is a genus of coelophysoid dinosaur that lived in what is now the eastern United States during the Early Jurassic Period between 201 and 190 million years ago. Its only known fossil was discovered by the geologist Mignon Talbot near Mount Holyoke, Massachusetts, in 1910. Some text to fill same len"
'===========================================================================================
Sub Pause(Optional iSec! = 1)
Dim iEnd!: iEnd = Timer + iSec
DoEvents
Do While Timer < iEnd: Loop
End Sub
'===========================================================================================
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Комбинируем 3 параметра между собой • длина строки (из нолей): 10, 100, 1000 • позиция искомого символа в строке: начало, середина, конец • искомый символ: 1 (не будет найден), "A" (начало алфавита), "M" (середина), "Z" (конец) Получаем 36 вариантов строк
Прогоняем 4 способа (каждый с 2мя вариантами поиска = 4*2 = 8 столбцов в таблице сравнения) 1 млн раз в цикле по полученным 36ти (строк в таблице сравнения) строкам
Сравнение
Таблица
Выводы
• Like отлично себя показал • RegExp для подобного поиска не годятся (зато незаменимы для сложных шаблонов) • штатный InStr хуже на коротком списке символов (3) и умирает на всём алфавите (26 символов) • InStr от BedVit'a (нужна библиотека) хорош (обгоняет Like), если выполнены 2 условия: 1. длинная строка 2. короткий список символов для поиска или искомый символ в начале списка
В целом, зависимость от положения символа прослеживается, так что тут без сюрпризов, зато тот факт, что поиск по 3ём символам или всему алфавиту для Like не так важен (а при росте количества "известных" символов диапазон заметно эффективнее — см. 1ый пост) — интересен
Код
Код
Option Explicit
Option Private Module
'===========================================================================================
Sub Final()
Dim RE1 As New RegExp, RE2 As New RegExp, BV As New BedvitCOM.VBA
Dim arrSymShort(), arrSymLong(), arrOut() As Double
Dim Ln, Pos, Ch, Sym, tx$, t!, n&, nMax&, r&, c&, flag As Boolean
Const mLike1$ = "*[A-Z]*", mLike2$ = "*[AMZ]*", mBV1$ = "A-Z", mBV2$ = "AMZ"
arrSymShort = Array("A", "M", "Z")
arrSymLong = Array("A", "B", "C", "D", "E", "F", "G", "H", "I", "J", "K", "L", "M", "N", "O", "P", "Q", "R", "S", "T", "U", "V", "W", "X", "Y", "Z")
RE1.Pattern = "[A-Z]": RE2.Pattern = "[AMZ]"
ReDim arrOut(1 To 36, 1 To 8): nMax = 1000000
For Each Ln In Array(String(10, "0"), String(100, "0"), String(1000, "0"))
For Each Pos In Array(1, Len(Ln) / 2, Len(Ln))
For Each Ch In Array(1, "A", "M", "Z")
r = r + 1: Application.StatusBar = "Row " & r & " out of " & UBound(arrOut, 1): DoEvents
tx = Ln: Mid$(tx, Pos, 1) = Ch: flag = (Ch <> 1): c = 1
t = Timer
For n = 1 To nMax ' RE
If RE1.Test(tx) <> flag Then Err.Raise xlErrNA
Next n
arrOut(r, c) = Timer - t: c = c + 1: t = Timer
For n = 1 To nMax
If RE2.Test(tx) <> flag Then Err.Raise xlErrNA
Next n
arrOut(r, c) = Timer - t: c = c + 1: t = Timer
For n = 1 To nMax ' Like
If (tx Like mLike1) <> flag Then Err.Raise xlErrNA
Next n
arrOut(r, c) = Timer - t: c = c + 1: t = Timer
For n = 1 To nMax
If (tx Like mLike2) <> flag Then Err.Raise xlErrNA
Next n
arrOut(r, c) = Timer - t: c = c + 1: t = Timer
For n = 1 To nMax ' InStr VBA
For Each Sym In arrSymLong
If InStr(tx, Sym) Then Exit For
Next Sym
Next n
arrOut(r, c) = Timer - t: c = c + 1: t = Timer
For n = 1 To nMax
For Each Sym In arrSymShort
If InStr(tx, Sym) Then Exit For
Next Sym
Next n
arrOut(r, c) = Timer - t: c = c + 1: t = Timer
For n = 1 To nMax ' InStr BedVit
For Each Sym In arrSymLong
If BV.InStr(tx, Sym) Then Exit For
Next Sym
Next n
arrOut(r, c) = Timer - t: c = c + 1: t = Timer
For n = 1 To nMax
For Each Sym In arrSymShort
If BV.InStr(tx, Sym) Then Exit For
Next Sym
Next n
arrOut(r, c) = Timer - t: c = c + 1: t = Timer
Next Ch, Pos, Ln
Application.StatusBar = False
shTest.Cells(4, 5).Resize(UBound(arrOut, 1), UBound(arrOut, 2)).Value2 = arrOut
Application.Calculate
End Sub
'===========================================================================================
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Jack Famous написал: Преобразовать латиницу в похожую кириллицу
Зачем там маски? проходим по массиву, меняем нужные символы. НЕ? 1.Напиши какие символы надо заменить на какие 2.Напиши тестовую строку (пример) 3.Напиши свое минимальное время для этого примера
Зачем там маски? Чтобы отсеять строки, в которых нет символов для замены и, как следствие, не "гонять" инстр с риплейсом Для того же, для чего быстрее не просто заменять подстроку, а сначала проверять её наличие инстром
Пункты 2 и 3 присутствуют в тесте (первый пост) Тестовая строка из первого поста мне не очень нравится - не всё охватывает Второй тест гораздо более масштабный - бери строки (36 штук хватит?) из него и тестируй (я уже сделал - не знаю, чего ты добиваешься)
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
bedvit, я рассмотрел 36 комбинаций - это немало, и, если я что-то не учёл или ошибся, то скажи, что именно, и тогда мы уже вместе перетестим Если ты запустишь тест и получишь другого рода данные (не равномерное отличие в скорости, а что-то принципиальное) — вот тогда надо разбираться Тест к запуску давно готов и я не понимаю, что ты ещё хочешь
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Задача: что быстрее и универсальнее лайка для проверки строки на содержание списка символов? Предварительный вывод (другого пока нет): иногда быстрее твой инстр, но в весьма узком месте (условия его лидерства описаны в #2)
Цитата
bedvit: могут быть альтернативные варианты решения
очень интересно будет посмотреть и сравнить В тестовый стенд легко включить новых игроков или удалить старых - я это предусмотрел
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Скрин 1: При полном сравнении в текущем тесте функция от BedVit'а проигрывает 10% среднего отклонения и 30% по итоговому времени Скрин 2: Однако, если не брать в расчёт экстремально длинные строки, появление которых редко при реальной работе, то Виталий уже выигрывает 20% среднего отклонения и те же 30% общего времени
Что это значит: • Like чертовски быстр, универсален и удобен в использовании • функция Виталия LikeUnicodeChar () определения наличия в строке любого символа из списка (поддерживаются диапазоны) скорее всего ускорит выполнение проверки в сравнении с Like. Наличие в ней третьего булевого параметра позволяет инвертировать маску и искать в строке любые символы НЕ из списка (как "[!symbols]" у Like) • InStr от Виталия сильно ускорит проверку, если список символов не более 5ти (примерно)
Код (создание массива строк вынесено в отдельную процедуру)
Код
Option Explicit
Option Private Module
'===========================================================================================
Sub LoadTestArrayOnSheet()
Dim arrTest()
CreateTestArray arrTest
Worksheets.Add After:=ActiveSheet
Cells(1, 1).Resize(UBound(arrTest, 1), UBound(arrTest, 2)).Value2 = arrTest
End Sub
'===========================================================================================
Sub CreateTestArray(arrTest())
Dim Ln, Pos, Ch, sym, tx$, r&
ReDim arrTest(1 To 36, 1 To 2)
For Each Ln In Array(String(10, "0"), String(100, "0"), String(1000, "0"))
For Each Pos In Array(1, Len(Ln) / 2, Len(Ln))
For Each Ch In Array("_", "A", "M", "Z")
tx = Ln: Mid$(tx, Pos, 1) = Ch
r = r + 1
arrTest(r, 1) = tx
arrTest(r, 2) = (Ch <> "_")
Next Ch, Pos, Ln
End Sub
'===========================================================================================
Sub Final()
Dim BV As New BedvitCOM.VBA
Dim x, arrTest(), arrOut() As Double
Dim tx$, t!, n&, nMax&, r&, c&, flag As Boolean
Const mLike$ = "*[A-Z]*", mBV$ = "A-Z"
CreateTestArray arrTest
ReDim arrOut(1 To UBound(arrTest, 1), 1 To 2): nMax = 1000000
For r = 1 To UBound(arrTest, 1)
Application.StatusBar = "Row " & r & " out of " & UBound(arrOut, 1): DoEvents
tx = arrTest(r, 1): flag = arrTest(r, 2): c = 1
t = Timer
For n = 1 To nMax ' BedVit
If BV.LikeUnicodeChar(tx, mBV) <> flag Then Err.Raise xlErrNA
Next n
arrOut(r, c) = Timer - t: c = c + 1: t = Timer
For n = 1 To nMax ' Like
If (tx Like mLike) <> flag Then Err.Raise xlErrNA
Next n
arrOut(r, c) = Timer - t: c = c + 1: t = Timer
Next r
Application.StatusBar = False
shTest.Cells(4, 5).Resize(UBound(arrOut, 1), UBound(arrOut, 2)).Value2 = arrOut
Application.Calculate
End Sub
'===========================================================================================
благодарю bedvit'а за единственный аналог и достойную конкуренцию!
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄