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&#0174;") > 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。实际结果是一个无限长的查询，其执行时间使其无法使用。 / p>

Answer 1

尝试处理从工作表中批量加载的数组，而不要遍历工作表的单元格。

您还应该“短路”选择标准。您的主要比较是P列是否为 North 。我认为合理的假设是，可能性为四分之一（N，N，S，E，W）或八分之一（N，N，NE，NW，S，SE，SW，E，W）。如果将所有选择条件放入相同的If语句中，则搜索 SUBSTRINGx 的次数比您需要的次数多。将对 North 的检查分成单独的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&#0174;", 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

有没有更快的方法来执行此循环指令功能？

2 个答案: