Каков самый быстрый способ превратить каждый элемент массива буквенно-цифровой?

Ответ 1

Не уверен, что это будет быстрее, потому что это зависит от слишком многих факторов, но может стоить тестирования. Вместо Regex. Замените каждое значение отдельно, вы можете получить скопированный текст диапазона из буфера обмена и сразу заменить все значения. Обратите внимание, что \w также соответствует символам подчеркивания и Юникода, поэтому более конкретное выражение в регулярном выражении может ускорить его выполнение.

'[a1:b30000] = [{"ABC123-009",""}]: Dim t As Double: t = Timer ' used for testing

Dim r As Range, s As String
Set r = ThisWorkbook.Worksheets("Data").UsedRange.Resize(, 1) ' Data!A1:A30000
With New MSForms.DataObject ' needs reference to "Microsoft Forms 2.0 Object Library" or use a bit slower late binding - With CreateObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
   r.Copy
   .GetFromClipboard
    Application.CutCopyMode = False
    s = .GetText
    .Clear ' optional - clear the clipboard if using Range.PasteSpecial instead of Worksheet.PasteSpecial "Text"

    With New RegExp ' needs reference to "Microsoft VBScript Regular Expressions 5.5" or use a bit slower late binding - With CreateObject("VBScript.RegExp")
        .Global = True
        '.IgnoreCase = False ' .IgnoreCase is False by default
        .Pattern = "[^0-9A-Za-z\r\n]+" ' because "[^\w\r\n]+" also matches _ and Unicode letters
        s = .Replace(s, vbNullString)
    End With

    .SetText s
    .PutInClipboard
End With

' about 70% of the time is spent here in pasting the data 
r(, 2).PasteSpecial 'xlPasteValues ' paste the text from clipboard in B1

'Debug.Print Timer - t

Я ожидаю, что это будет медленнее для меньших значений из-за накладных расходов буфера обмена и, возможно, медленнее для получения большего количества значений из-за необходимой памяти.

Отключение событий, похоже, не повлияло на мои тесты, но, возможно, стоит попробовать.

Обратите внимание, что есть небольшой шанс использования другого приложения, использующего буфер обмена, в то время как макрос использует его.

Если раннее связывание вызывает проблемы при запуске одного и того же скомпилированного макроса на разных машинах, вы можете выполнить поиск декомпилятор макроса или удалить ссылки и переключиться к позднему связыванию.

Ответ 2

tl; dr - Регулярные выражения уничтожают реализацию VBA. Если это вызов кода, @brettj или @Slai должны выиграть его.

Есть несколько трюков, чтобы сделать ваш AlphaNumericOnly быстрее.

Во-первых, вы можете избавиться от подавляющего большинства вызовов функций, рассматривая его как байтовый массив вместо строки. Это удаляет все вызовы Mid$ и Asc. Хотя это невероятно быстрые функции, они по-прежнему добавляют накладные расходы и выскакивают из стека вызовов. Это составляет более сотни тысяч итераций.

Вторая оптимизация - не использовать синтаксис Case x To y, если вы можете его избежать. Причина связана с тем, как он компилируется - он не компилируется для теста типа Case = Condition >= x And Condition <= y, он фактически создает цикл с условием раннего выхода следующим образом:

Case = False
For i = x To y
    If Condition = i Then
        Case = True
    End If
Next

Опять же, не огромный удар по производительности, но он складывается. Третья оптимизация заключается в том, чтобы упорядочить ваши тесты таким образом, чтобы они сортировали схему по наиболее вероятным ударам в вашем наборе данных. Я приспособил свои примеры ниже для писем в основном, причем большинство из них - в верхнем регистре. Вы можете сделать лучше с другим порядком. Поместите все это вместе, и вы получите что-то похожее на это:

Public Function ByteAlphaNumeric(source As Variant) As String
    Dim chars() As Byte
    Dim outVal() As Byte
    chars = CStr(source)        'Load the array up.

    Dim bound As Long
    bound = UBound(chars)       'Size the outbound array.
    ReDim outVal(bound)

    Dim i As Long, pos As Long
    For i = 0 To bound Step 2   'Wide characters, only care about the ASCII range.
        Dim temp As Byte
        temp = chars(i)         'Pointer math isn't free. Cache it.
        Select Case True        'Order is important here.
            Case temp > 64 And temp < 91
                outVal(pos) = temp
                pos = pos + 2   'Advance the output pointer.
            Case temp < 48
            Case temp > 122
            Case temp > 96
                outVal(pos) = temp
                pos = pos + 2
            Case temp < 58
                outVal(pos) = temp
                pos = pos + 2
        End Select
    Next
    'This is likely the most expensive operation.
    ReDim Preserve outVal(pos)  'Trim the output array.
    ByteAlphaNumeric = outVal
End Function

Как это сделать? Довольно хорошо:

Public Sub Benchmark()
    Dim starting As Single, i As Long, dummy As String, sample As Variant

    sample = GetRandomString

    starting = Timer
    For i = 1 To 1000000
        dummy = AlphaNumericOnlyOP(sample)
    Next i
    Debug.Print "OP AlphaNumericOnly: ", Timer - starting

    starting = Timer
    For i = 1 To 1000000
        dummy = AlphaNumericOnlyThunderframe(sample)
    Next i
    Debug.Print "ThunderFrame AlphaNumericOnly: ", Timer - starting

    starting = Timer
    For i = 1 To 1000000
        dummy = AlphaNumeric(sample)
    Next i
    Debug.Print "CallumDA33 AlphaNumeric: ", Timer - starting

    starting = Timer
    For i = 1 To 1000000
        dummy = ByteAlphaNumeric(sample)
    Next i
    Debug.Print "ByteAlphaNumeric: ", Timer - starting

    Dim cast As String
    cast = CStr(sample)
    starting = Timer
    For i = 1 To 1000000
        dummy = ByteAlphaNumericString(cast)
    Next i
    Debug.Print "ByteAlphaNumericString: ", Timer - starting

    Set stripper = Nothing
    starting = Timer
    For i = 1 To 1000000
        dummy = OptimizedRegex(sample)
    Next i
    Debug.Print "OptimizedRegex: ", Timer - starting

End Sub

Private Function GetRandomString() As Variant
    Dim chars(30) As Byte, i As Long
    Randomize
    For i = 0 To 30 Step 2
        chars(i) = Int(96 * Rnd + 32)
    Next i
    Dim temp As String
    temp = chars
    GetRandomString = CVar(temp)
End Function

Результаты с 15 символами случайных String:

OP`s AlphaNumericOnly:                     6.565918 
ThunderFrame`s AlphaNumericOnly:           3.617188 
CallumDA33`s AlphaNumeric:                23.518070 
ByteAlphaNumeric:                          2.354980

Заметьте, я пропустил представления, которые не были тривиальными для преобразования в функции. Вы можете заметить 2 дополнительных теста: ByteAlphaNumericString точно такой же, как и функция ByteAlphaNumeric, но вместо Variant он принимает String и избавляется от приведения. Это не тривиально:

ByteAlphaNumericString:                    2.226074

И, наконец, неуловимая функция OptimizedRegex (в основном код @brettj в форме функции для сравнения):

Private stripper As RegExp  'Module level

Function OptimizedRegex(strSource As Variant) As String
    If stripper Is Nothing Then
        Set stripper = New RegExp
        With stripper
            .Global = True
            .Pattern = "[^0-9A-Za-z]"
        End With
    End If
    OptimizedRegex = stripper.Replace(strSource, vbNullString)
End Function

OptimizedRegex:                            1.094727 

EDIT: выполнение бонуса!

Мне пришло в голову, что поиск в хэш-таблице может быть быстрее структуры Select Case, поэтому я построил один с помощью Scripting.Dictionary:

Private hash As Scripting.Dictionary  'Module level

Function HashLookups(source As Variant) As String
    Dim chars() As Byte
    Dim outVal() As Byte

    chars = CStr(source)
    Dim bound As Long
    bound = UBound(chars)
    ReDim outVal(bound)

    Dim i As Long, pos As Long
    With hash
        For i = 0 To bound Step 2
            Dim temp As Byte
            temp = chars(i)
            If .Exists(temp) Then
                outVal(pos) = temp
                pos = pos + 2
            End If
        Next
    End With
    ReDim Preserve outVal(pos)
    HashLookups = outVal
End Function

Private Sub LoadHashTable()
    Set hash = New Scripting.Dictionary
    Dim i As Long
    For i = 48 To 57
        hash.Add i, vbNull
    Next
    For i = 65 To 90
        hash.Add i, vbNull
    Next
    For i = 97 To 122
        hash.Add i, vbNull
    Next
End Sub

'Test code:
    starting = Timer
    LoadHashTable
    For i = 1 To 1000000
        dummy = HashLookups(sample)
    Next i
    Debug.Print "HashLookups: ", Timer - starting

Это оказалось не слишком потрепанным:

HashLookups:                               1.655273

Окончательная версия

Проснулся и подумал, что попробую векторный поиск вместо поиска хэша (просто заполните байтовый массив значений, чтобы сохранить и использовать это для тестов). Это кажется разумным в том, что это всего лишь 256-элементный массив - в основном таблица истинности:

Private lookup(255) As Boolean 'Module level

Function VectorLookup(source As Variant) As String
    Dim chars() As Byte
    Dim outVal() As Byte

    chars = CStr(source)
    Dim bound As Long
    bound = UBound(chars)
    ReDim outVal(bound)

    Dim i As Long, pos As Long
    For i = 0 To bound Step 2
        Dim temp As Byte
        temp = chars(i)
        If lookup(temp) Then
            outVal(pos) = temp
            pos = pos + 2
        End If
    Next
    ReDim Preserve outVal(pos)
    VectorLookup = outVal
End Function

Private Sub GenerateTable()
    Dim i As Long
    For i = 48 To 57
        lookup(i) = True
    Next
    For i = 65 To 90
        lookup(i) = True
    Next
    For i = 97 To 122
        lookup(i) = True
    Next
End Sub

Предполагая, что таблица поиска генерируется только один раз, она работает примерно на 10-15% быстрее, чем любой другой чистый метод VBA выше.

Ответ 3

Кредит ThunderFrame (я присоска для LHS Mid$), но я получил лучшую производительность с ранней привязки RegExp с дополнительными небольшими настройками:

• Используйте Value2 вместо Value
• Объявите свой цикл длинным целым числом
• .ignorecase = True является избыточным

код

    Sub Replace2()

    Dim inputSh As Worksheet
    Dim inputRng As Range
    Set inputSh = Sheets("Data")
    Set inputRng = inputSh.Range("A1:A30000")

    Dim outputSh As Worksheet
    Dim outputRng As Range
    Set outputSh = Sheets("Replace")
    Set outputRng = outputSh.Range("A1:A30000")

    Dim time1 As Double, time2 As Double
    time1 = MicroTimer

    Dim arr As Variant
    Dim objRegex As VBScript_RegExp_55.RegExp
    Dim i As Long

    Set objRegex = CreateObject("vbscript.regexp")
    With objRegex
            .Global = True
            .Pattern = "[^\w]"
    End With

    arr = inputRng.Value2
    For i = LBound(arr) To UBound(arr)
            arr(i, 1) = objRegex.Replace(arr(i, 1), vbNullString)
    Next i
    outputRng.Value2 = arr

    time2 = MicroTimer
    Debug.Print (time2 - time1) * 1000
    End Sub

Ответ 4

Если вы измените функцию в своей первой, и в настоящее время наиболее эффективной процедуре, на следующее, вы получите повышение производительности не менее 40-50% в зависимости от ваших данных:

Function AlphaNumericOnly(strSource As Variant) As String
    Dim i As Long
    Dim charCount As Long
    Dim strResult As String
    Dim char As String
    strResult = Space$(Len(strSource))
    For i = 1 To Len(strSource)
        char = Mid$(strSource, i, 1)
        Select Case Asc(char)
            Case 48 To 57, 65 To 90, 97 To 122: 'include 32 if you want to include space
                charCount = charCount + 1
                Mid$(strResult, charCount, 1) = char
        End Select
    Next
    AlphaNumericOnly = Left$(strResult, charCount)
End Function

Я использовал несколько оптимизаций, но главным образом, вы повторно назначали strResult несколько раз в цикле, что очень дорого и даже дороже, когда ваши строки больше (и цикл работает больше). Гораздо лучше использовать Mid$.

И, используя функции $-suffixed, оптимизированы для строк, поэтому вы также получите лучшую производительность

Оптимизация версии RegEx

Ваш подход Regex имеет разумную производительность, но вы используете позднюю привязку CreateObject, которая будет намного быстрее, чем ранняя привязанная строго типизированная ссылка.

Кроме того, ваш шаблон и параметры Regex одинаковы каждый раз, вы можете объявить объект regex как переменную и только создать его, если он еще не существует, а затем повторно использовать существующее регулярное выражение каждый раз.

Ответ 5

Я выброшу это там, если больше ничего не увижу, как это работает. Я уверен, что его тоже можно было бы прибрать.

Моя надежда заключается в том, что метод проверки того, является ли символ буквой, быстрее. Я уверен, что тестирование на число можно сделать немного быстрее.

Function AlphaNumeric(s As String) As String
    Dim char As String, tempStr As String
    Dim i As Integer
    Dim t As Variant

    For i = 1 To Len(s)
        char = Mid(s, i, 1)
        If IsLetter(char) Or IsNumber(char) Then
            tempStr = tempStr & char
        End If
    Next i
    AlphaNumeric = tempStr
End Function

Private Function IsLetter(s As String) As Boolean
    If UCase(s) = s And LCase(s) = s Then
        IsLetter = False
    Else:
        IsLetter = True
    End If
End Function

Private Function IsNumber(s As String)
    On Error GoTo 1
    s = s * 1
    IsNumber = True
    Exit Function
1:
    IsNumber = False
End Function