Excel VBA InStr非常慢并且挂起

Question

我正在使用下面的VBA代码将“ Sheet1”中的60K记录（仅特定字符串）与“ Sheet2”中的7K记录进行比较。 这需要很长时间才能完成，有时甚至没有响应。 是否有任何方法可以改善此子例程的性能？

Sub txtext()

Dim fnl As String, stl As String, env As String, typ As String
Dim ctm As String
Dim stdate As Date, enddate As Date

lr = Sheets("cid_match").Range("A" & Rows.Count).End(xlUp).Row
cr = Sheets("scme").Range("C" & Rows.Count).End(xlUp).Row
stdate = Now
m = 2

For Each e In Sheets("cid_match").Range("BI2:BI" & lr).Cells
stl = Worksheets("cid_match").Range("BI" & m).Cells.Value
typ = Worksheets("cid_match").Range("BK" & m).Cells.Value
s = 2
    For Each r In Sheets("scme").Range("C2:C" & cr).Cells
        ctm = Worksheets("scme").Range("B" & s).Cells.Value
        fnl = r.Value

        If InStr(fnl, stl) > 0 And ctm = typ Then
            Worksheets("cid_match").Range("BJ" & m).Value = fnl
            GoTo sss
        End If
    s = s + 1
    Next r
sss:
m = m + 1
Next e

enddate = Now
MsgBox "Succesfully Completed!!! Started at " & stdate & " Ended at " & enddate

End Sub

Answer 1

为了优化搜索记录，您首先要使用quicksort或bubbleort对数据进行排序 。 然后，您将可以使用二进制搜索进行搜索 。 这将大大减少您的等待时间。 幸运的是，这些功能已经由其他开发人员在VBA中编写。

冒泡

Sub BubbleSort(list()) 
'   Sorts an array using bubble sort algorithm
    Dim First As Integer, Last As Long 
    Dim i As Long, j As Long 
    Dim Temp As Long 

    First = LBound(list) 
    Last = UBound(list) 
    For i = First To Last - 1 
        For j = i + 1 To Last 
            If list(i) > list(j) Then 
                Temp = list(j) 
                list(j) = list(i) 
                list(i) = Temp 
            End If 
        Next j 
    Next i 
End Sub 

二元搜寻

Function arrayFind(theArray() As Integer, target As Integer) As Boolean
    Dim low As Integer
    low = 0
    Dim high As Integer
    high = UBound(theArray)
    Dim i As Integer
    Dim result As Boolean

    Do While low <= high
        i = (low + high) / 2
        If target = theArray(i) Then
            arrayFind = True
            Exit Do
        ElseIf target < theArray(i) Then
            high = (i - 1)
        Else
            low = (i + 1)
        End If
    Loop

    If Not arrayFind Then
        arrayFind = False
    End If
End Function

Answer 2

请尝试以下方法：-

Sub Sample()
Dim AryLookup()     As String
Dim DteStart        As Date
Dim LngCounter      As Long
Dim LngRow          As Long
Dim WkSht           As Worksheet

DteStart = Now

'Look at the lookup worksheet
Set WkSht = ThisWorkbook.Worksheets("scme")

    'Make an array the same size as the dataset
    ReDim AryLookup(WkSht.Range("C" & Rows.Count).End(xlUp).Row)

    'Copy the dataset in
    For LngRow = 2 To UBound(AryLookup, 1)
        AryLookup(LngRow - 2) = WkSht.Range("C" & LngRow)
        DoEvents
    Next

Set WkSht = Nothing

'Look at the source worksheet
Set WkSht = ThisWorkbook.Worksheets("cid_match")

    'Work from the bottom up so not to be falsly stopped by an empty row
    'Step -1 means go backwards by one with each itteration of the loop
    For LngRow = WkSht.Range("A" & Rows.Count).End(xlUp).Row To 2 Step -1

        'Look through the loop for a match
        For LngCounter = 0 To UBound(AryLookup, 1)

            'If it matches then add it to the column and exit the loop
            If InStr(1, WkSht.Range("BI" & LngRow), AryLookup(LngCounter)) > 0 Then
                WkSht.Range("BJ" & LngRow).Value = AryLookup(LngCounter)
                Exit For
            End If

            DoEvents
        Next

        DoEvents
    Next
Set WkSht = Nothing

MsgBox "Succesfully Completed!!! " & vbNewLine & "Started at " & DteStart & vbNewLine & "Ended at " & Now

End Sub

查看您的代码很容易跟上正在发生的事情，在某些情况下，我无法理解或看不到代码中正在发生的事情的好处，因此上述内容可能是不正确的。 您应该始终在假设另一位开发人员有一天需要拾起代码并提供支持的前提下编写代码，如果您在数年后必须返回代码并想记住发生了什么，它将在将来为您提供帮助。