Алгоритм медленного поиска / фильтрации

Question

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

У меня есть наборы данных в строках, которые выглядят так:

Мне нужно отфильтровать / найти такие значения, как числа (например, показать все> 30). Но некоторые записи, такие как 30|32,89, не являются числами. Прямо сейчас я проверяю каждое значение, если оно должно быть разделено, как 30|32,89 в 30 и 32,89, и записываю все значения в лист. Итак, у меня есть столбец, где все значения являются числами. Со вторым столбцом, в котором сохраняется исходный номер строки, например:

После этого я использую расширенный фильтр для получения нужных мне данных. Я пишу это в другой колонке. Использование исходных номеров строк для записи значений только из одной исходной ячейки, если несколько чисел в этой ячейке соответствуют критериям поиска. И для этого я сохраняю все исходные данные (20 столбцов и много строк) в двумерном массиве. Затем я беру только значения из этого массива, где 1-й индекс соответствует исходному номеру строки отфильтрованных данных, и записываю все значения по одному на другом листе подряд для каждого 1-го индекса (эта часть вызывает большинство медлительность). Есть 20 значений для каждого первого индекса. Итак, в конце я получаю все соответствующие данные для отфильтрованных элементов, показанных в одной таблице.

Вот мой код для этого:

Public Sub numberSearch(srchCol As String, srchValue As String)
    Dim sValues As Variant, wRange As Variant

    'temp values
    cRow = archSh.Range("A1").CurrentRegion.rowS.count
    Dim srchCol As String
    srchCol = "B"
    Dim srchValue As String
    srchValue = ">2005"
    '------------------

    'prepare sheet
    shSearch.Cells.Clear
    sValues = Application.Transpose(archSh.Range(srchCol & "2", srchCol & cRow))
    wRange = archSh.Range("A1").CurrentRegion
    shSearch.Range("A1").Value = archSh.Range(srchCol & "1").Value
    shSearch.Range("B1").Value = "tst"
    shSearch.Range("D1").Value = shSearch.Range("A1").Value
    shSearch.Range("E1").Value = shSearch.Range("B1").Value
    shSearch.Range("G1").Value = shSearch.Range("A1").Value
    shSearch.Range("H1").Value = shSearch.Range("B1").Value
    shSearch.Range("D2").Value = srchValue
    '----------------------------
    'spilt values, make all numeric
    Dim i As Long, j As Long, k As Long
    Dim tst As Variant, c As Variant
    Dim s
    i = 2
    k = 2
    For Each c In sValues
        If IsNumeric(c) = True Then
            ReDim tst(0 To 0)
            tst(0) = c
        Else
            tst = Split(c, sepa)
        End If
        For j = 0 To UBound(tst)
            shSearch.Range("A" & k + j).Value = tst(j)
            shSearch.Range("B" & k + j).Value = i
        Next j
        i = i + 1
        k = k + UBound(tst) - LBound(tst) + 1
    Next
    '--------------------------------
    'filter data
    Dim rgData As Range, rgCrit As Range, rgOut As Range
    Set rgData = shSearch.Range("A1").CurrentRegion
    Set rgCrit = shSearch.Range("D1").CurrentRegion
    Set rgOut = shSearch.Range("G1").CurrentRegion
    rgData.AdvancedFilter xlFilterCopy, rgCrit, rgOut
    '---------------------------------
    'write searched data
    Dim searchColVal As Variant
    searchColVal = Application.Transpose(shSearch.Range("H1:H" & shSearch.Cells(rowS.count, 8).End(xlUp).row))
    Dim tempItem As Long
    tempItem = 0
    k = 4
    tmpSh.Range("A4").CurrentRegion.Clear
    archSh.Range("A1:T1").Copy tmpSh.Range("A4")
    For i = 2 To UBound(searchColVal)
        If tempItem <> searchColVal(i) Then
            ReDim Preserve filterRow(1 To k - 3)
            filterRow(k - 3) = searchColVal(i)
            k = k + 1
            tempItem = searchColVal(i)
            For j = 1 To UBound(wRange, 2)
                tmpSh.Cells(k, j).Value = wRange(searchColVal(i), j)
            Next j
        End If
    Next i
    '----------------------------------------
End Sub

Может кто-нибудь помочь мне с ускорением этого беспорядка пожалуйста? Ты заранее.

Answer 1

Вы можете сделать это с помощью Advanced Filter и критериев формулы.

Мы используем FILTERXML (доступно в Excel 2013 +) для разделения текстовых значений. Мы также являемся функцией ISNUMBER для исключения текстовых значений из значения TRUE путем сравнения в первой формуле.

А в расширенном фильтре есть возможность записывать результаты в другом месте

Для вашего примера, две формулы могут быть:

=AND(ISNUMBER(A9),A9>30)
=OR(FILTERXML("<t><s>" & SUBSTITUTE(A9,"|","</s><s>") & "</s></t>","//s")>30)

Перед фильтром

После фильтра

Или, если вы измените критерии в обеих формулах для >30 на <30

В зависимости от того, что вам нужно, вы можете использовать VBA для генерации соответствующих формул.

Answer 2

Это просматривает столбец, разбивает значение ячейки на массив, затем использует Оценка , чтобы применить значение поиска.

Public Sub numberSearch2()

    Const COL_FILTER = "B"
    Const srchValue = ">2005"

    Dim wb As Workbook, wsSource As Worksheet, WsTarget, t0 As Single
    Dim iRow As Long, iLastRow As Long, iTargetRow As Long
    Dim ar As Variant, i As Integer
    t0 = timer

    Set wb = ThisWorkbook
    Set wsSource = wb.Sheets("Sheet2")
    Set WsTarget = wb.Sheets("Sheet3")
    WsTarget.Cells.Clear
    wsSource.Rows(1).EntireRow.Copy WsTarget.Range("A1")
    iTargetRow = 2

    With wsSource
        iLastRow = .Range(COL_FILTER & Rows.Count).End(xlUp).Row
        For iRow = 2 To iLastRow
            ar = Split(.Cells(iRow, COL_FILTER), "|")
            For i = 0 To UBound(ar)
                If Evaluate(ar(i) & srchValue) Then
                    wsSource.Rows(iRow).EntireRow.Copy WsTarget.Cells(iTargetRow, 1)
                    iTargetRow = iTargetRow + 1
                    i = UBound(ar) ' exit loop
                End If
            Next
        Next
    End With

    MsgBox iLastRow - 1 & " rows read " & vbCr & _
           iTargetRow - 2 & " rows written", vbInformation, "Completed in " & Int(timer - t0) & " secs"

End Sub