Есть ли более быстрый способ сделать эту функцию цикла цикла?

Question

У меня большой набор данных (т.е. 100 000+ строк).Мне нужно перебрать значения в одном или нескольких столбцах, и если условия instr равны TRUE , я обновлю значение другого столбца до 1. Однако первая написанная мной функция цикла занимает слишком много времени для запуска (явынужден бросить через пять минут).Есть ли способ написать эту функцию, которая будет выполняться быстрее?

Я попытался использовать несколько if / then вместо одного if / then, но это не сработало.

Sub bucketup()

Dim SrchRng As Range, cel As Range
Dim LastRow As Long
LastRow = ActiveSheet.UsedRange.SpecialCells(xlCellTypeLastCell).Row

Set SrchRng = Range("Data!D4:D" & LastRow)

For Each cel In SrchRng

    '''''' Check 1 ''''''

        'Check 1 Sub 1'
        If cel.Offset(0, 12).Value = "North" AND (InStr(1, UCase(cel.Value), "SUBSTRING®") > 0 Or InStr(1, UCase(cel.Value), "SUBSTRING®") > 0 Or InStr(1, UCase(cel.Value), "SUBSTRING®") > 0) Then
            cel.Offset(0, 15).Value = 1
        End If

Next cel

End Sub

ожидаемый результат состоял в том, что для каждой строки where column P = "North" и столбца D, содержащего одну из подстрок, столбец S будет установлен в 1. Фактический результат - это неопределенно длинный запрос, время выполнения которого делает его непригодным для использования.

Answer 1

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

Вам также следует «замкнуть» ваши критерии выбора. Ваше основное сравнение заключается в том, является ли столбец P Север . Я думаю, что разумно предположить, что возможны либо 1 в 4 (N в N, S, E, W), либо 1 в 8 (N в N, NE, NW, S, SE, SW, E, W). Если вы поместите все критерии выбора в один и тот же оператор If, тогда вы будете искать SUBSTRINGx гораздо больше, чем нужно. Разбейте проверку для Север на отдельный оператор If и продолжайте проверять, только если найдено совпадение.

Option Explicit

Sub bucketup()

    Dim SrchRng As Range, cel As Range
    Dim searchArr As Variant, resultArr As Variant
    Dim i As Long

    With Worksheets(ActiveSheet.Name)

        searchArr = .Range(.Cells(4, "D"), .Cells(.Rows.Count, "D").End(xlUp).Offset(0, 12)).Value2
        ReDim resultArr(LBound(searchArr, 1) To UBound(searchArr, 1), 1 To 1)

        For i = LBound(searchArr, 1) To UBound(searchArr, 1)

            If searchArr(i, 13) = "North" Then
                If InStr(1, searchArr(i, 1), "SUBSTRING®", vbTextCompare) > 0 Or _
                   InStr(1, searchArr(i, 1), "SUBSTRING®", vbTextCompare) > 0 Or _
                   InStr(1, searchArr(i, 1), "SUBSTRING®", vbTextCompare) > 0 Then
                    resultArr(i, 1) = 1
                End If
            End If
        Next i

        .Cells(4, "S").Resize(UBound(resultArr, 1), UBound(resultArr, 2)) = resultArr

    End With

End Sub

Answer 2

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

Option Explicit
Sub Find_Cell_Value()

  Dim c As Range
  Dim firstaddress As String
  Dim Lastrow As Long
  Dim Look as Worksheet

  Set Look = ActiveSheet

  Lastrow = Look.Cells(Rows.Count, "P").End(xlUp).Row

  With Look.Range("P2:P" & Lastrow)
  Set c = .Find("North", LookIn:=xlValues)

  If Not c Is Nothing Then
  firstaddress = c.Address

  Do

  If InStr(Look.Cells(c.Row, "D"), "SUBSTRING&#0174") > 0 _
  Or InStr(Look.Cells(c.Row, "D"), "SUBSTRING®") > 0 _
  Or InStr(Look.Cells(c.Row, "D"), "SUBSTRING®") > 0 Then
  Look.Cells(c.Row, "C") = 1
  End If

  Set c = .FindNext(c)

  If c Is Nothing Then
  GoTo DoneFinding
  End If

  Loop While c.Address <> firstaddress
  End If

DoneFinding:
  End With

End Sub