vba - 加快excel中的循环

Question

我得到了一些很大的帮助来让这个搜索工具在 excel 中工作，但我想知道是否还有提高速度的空间。我做了一些研究，我对 VB for i = LBOUND(array) To UBOUND(array) 的了解很少，似乎是最理想的。'For Each' 会更快吗？我想知道是否有办法隔离当前工作表中的记录，或者它是否已经在使用 L/UBOUND 进行此操作？如果是，有没有办法像 SQL 一样“忽略特殊字符”？添加屏幕更新和计算后，我能够将总运行时间缩短约 10 秒。此外，在这个新循环之前，我使用 FormulaR1C1 进行搜索，它会限制要搜索的列数量，同时速度非常快。

Range("W2:W" & LastRow).FormulaR1C1 = _
"=IF(ISERR(SEARCH(R1C23,RC[-22]&RC[-21]&RC[-20]&RC[-19]&RC[-18]&RC[-17]&RC[-16]&RC[-15]&RC[-15]&RC[-14]&RC[-13]&RC[-12]&RC[-11]&RC[-10]&RC[-9]&RC[-8]&RC[-7]&RC[-6]&RC[-5]&RC[-4]&RC[-3]&RC[-2]&RC[-1])),0,1)"
If WorksheetFunction.CountIf(Columns(23), 1) = 0 Then
Columns(23).Delete

非常感谢任何帮助或建议。

    Sub FindFeature()
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Dim shResults As Worksheet
    Dim vaData As Variant
    Dim i As Long, j As Long
    Dim sSearchTerm As String
    Dim sData As String
    Dim rNext As Range
    Dim v As Variant
    Dim vaDataCopy As Variant
    Dim uRange As Range
    Dim findRange As Range
    Dim nxtRange As Range
    Dim ws As Range

    'Put all the data into an array
    vaData = ActiveSheet.UsedRange.Value

    'Get the search term
    sSearchTerm = Application.InputBox("What are you looking for?")

    'Define and clear the results sheet
    Set shResults = ActiveWorkbook.Worksheets("Results")
    shResults.Range("A3").Resize(shResults.UsedRange.Rows.Count, 1).EntireRow.Delete

    Set uRange = ActiveSheet.UsedRange
    vaData = uRange.Value
    vaDataCopy = vaData
    For Each v In vaDataCopy
        v = Anglicize(v)
    Next
    Application.WorksheetFunction.Transpose (vaDataCopy)
    ActiveSheet.UsedRange.Value = vaDataCopy

    'Loop through the data

    Set ws = Cells.Find(What:=uRange, After:="ActiveCell", LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)

    If Not ws Is Nothing Then
        Set findRange = ws
        Do
            Set nxtRange = Cells.FindNext(After:=ws)
                Set findRange = nxtRange
        Loop Until ws.Address = findRange.Address

        ActiveSheet.UsedRange.Value = vaData
                'Write the row to the next available row on Results
                Set rNext = shResults.Cells(shResults.Rows.Count, 1).End(xlUp).Offset(1, 0)
                rNext.Resize(1, uRange(vaData, 2)).Value = Application.Index(vaData, i, 0)
                'Stop looking in that row after one match
            End If
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
End Sub

Answer 1

最终，这里的执行速度受到对范围内每个单元格的明显要求的严重阻碍，并且因为您询问性能，我怀疑这个范围可能包含数千个单元格。我能想到的有两点：

1. 将您的结果保存在一个数组中，并在一个语句中写入结果工作表

尝试替换这个：

'Write the row to the next available row on Results
Set rNext = shResults.Cells(shResults.Rows.Count, 1).End(xlUp).Offset(1, 0)
rNext.Resize(1, UBound(vaData, 2)).Value = Application.Index(vaData, i, 0)
'Stop looking in that row after one match
Exit For

使用将值分配给Application.Index(vaData, i, 0)数组变量的语句，然后当您完成For i循环时，您可以将结果一次性写入结果工作表。

注意当且仅当有数千个结果时，这可能会明显更快。如果预期的结果很少，则执行速度主要受迭代每个单元格的需要影响，而不是将结果写入另一个工作表的操作。

2. 使用单元迭代以外的其他方法

如果你能实现这个方法，我会结合上面的使用它。

通常，我建议使用.Findand.FindNext方法比使用i,j迭代更有效。但是由于您需要Anglicize在范围内的每个单元格上使用 UDF，因此您需要对代码进行一些重组以适应。可能需要多个循环，例如，首先Anglicize并vaData保留非英语化数据的副本，例如：

Dim r as Long, c as Long
Dim vaDataCopy as Variant
Dim uRange as Range

Set uRange = ActiveSheet.UsedRange
vaData = uRange.Value
vaDataCopy = vaData
For r = 1 to Ubound(varDataCopy,1)
    For c = 1 to Ubound(varDataCopy,2)
        varDataCopy(r,c) = Anglicize(varDataCopy(r,c))
    Next
Next

然后，将Anglicize版本放到工作表中。

ActiveSheet.UsedRange.Value = vaDataCopy

然后，在对象上使用and方法而不是For i =... For j =...循环。.Find.FindNextuRange

这是我如何实现 Find/FindNext 的示例。

最后，将非英语版本放回工作表上，再次注意它可能需要使用Transpose函数：

ActiveSheet.UsedRange.Value = vaData

虽然这仍然迭代每个值以执行Anglicize函数，但它不会第二次对每个值进行操作（Instr函数）。因此，您实际上只对这些值进行了一次操作，而不是两次。我怀疑这应该更快，特别是如果你将它与上面的#1结合起来。

基于 OP 修订工作的更新

经过一些评论讨论和来回电子邮件，我们得出了这个解决方案：

Option Explicit
Sub FindFeature()
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Dim shSearch As Worksheet:
    Dim shResults As Worksheet
    Dim vaData As Variant
    Dim i As Long, j As Long, r As Long, c As Long
    Dim sSearchTerm As String
    Dim sData As String
    Dim rNext As Range
    Dim v As Variant
    Dim vaDataCopy As Variant
    Dim uRange As Range
    Dim findRange As Range
    Dim nxtRange As Range
    Dim rng As Range
    Dim foundRows As Object
    Dim k As Variant

    Set shSearch = Sheets("City")
    shSearch.Activate
    'Define and clear the results sheet
    Set shResults = ActiveWorkbook.Worksheets("Results")
    shResults.Range("A3").Resize(shResults.UsedRange.Rows.Count, 1).EntireRow.Delete

    '# Create a dictionary to store our result rows
    Set foundRows = CreateObject("Scripting.Dictionary")

    'Get the search term
    sSearchTerm = Application.InputBox("What are you looking for?")

    '# set and fill our range/array variables
    Set uRange = shSearch.UsedRange
    vaData = uRange.Value
    vaDataCopy = Application.Transpose(vaData)
    For r = 1 To UBound(vaDataCopy, 1)
        For c = 1 To UBound(vaDataCopy, 2)
        'MsgBox uRange.Address
            vaDataCopy(r, c) = Anglicize(vaDataCopy(r, c))
        Next
    Next

    '# Temporarily put the anglicized text on the worksheet
    uRange.Value = Application.Transpose(vaDataCopy)

    '# Loop through the data, finding instances of the sSearchTerm
    With uRange
        .Cells(1, 1).Activate
        Set rng = .Cells.Find(What:=sSearchTerm, After:=ActiveCell, _
                    LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, _
                    SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)

        If Not rng Is Nothing Then
            Set findRange = rng
            Do
                Set nxtRange = .Cells.FindNext(After:=findRange)
                Debug.Print sSearchTerm & " found at " & nxtRange.Address

                If Not foundRows.Exists(nxtRange.Row) Then
                    '# Make sure we're not storing the same row# multiple times.
                    '# store the row# in a Dictionary
                    foundRows.Add nxtRange.Row, nxtRange.Column
                End If

                Set findRange = nxtRange

            '# iterate over all matches, but stop when the FindNext brings us back to the first match
            Loop Until findRange.Address = rng.Address

            '# Iterate over the keys in the Dictionary.  This contains the ROW# where a match was found
            For Each k In foundRows.Keys
                '# Find the next empty row on results page:
                With shResults
                    Set rNext = .Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0). _
                                Resize(1, UBound(Application.Transpose(vaData), 1))
                End With
                '# Write the row to the next available row on Results
                rNext.Value = Application.Index(vaData, k, 0)
            Next
        Else:
            MsgBox sSearchTerm & " was not found"
        End If
    End With

    '# Put the non-Anglicized values back on the sheet
    uRange.Value = vaData
    '# Restore application properties
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    '# Display the results
    shResults.Activate
End Sub

Public Function Anglicize(ByVal sInput As String) As String

    Dim vaGood As Variant
    Dim vaBad As Variant
    Dim i As Long
    Dim sReturn As String
    Dim c As Range

    'Replace any 'bad' characters with 'good' characters

    vaGood = Split("S,Z,s,z,Y,A,A,A,A,A,A,C,E,E,E,E,I,I,I,I,D,N,O,O,O,O,O,U,U,U,U,Y,a,a,a,a,a,a,c,e,e,e,e,i,i,i,i,d,n,o,o,o,o,o,u,u,u,u,y,y", ",")
    vaBad = Split("Š,Ž,š,ž,Ÿ,À,Á,Â,Ã,Ä,Å,Ç,È,É,Ê,Ë,Ì,Í,Î,Ï,Ð,Ñ,Ò,Ó,Ô,Õ,Ö,Ù,Ú,Û,Ü,Ý,à,á,â,ã,ä,å,ç,è,é,ê,ë,ì,í,î,ï,ð,ñ,ò,ó,ô,õ,ö,ù,ú,û,ü,ý,ÿ", ",")
    sReturn = sInput

    Set c = Range("D1:G1")
        For i = LBound(vaBad) To UBound(vaBad)
            sReturn = Replace$(sReturn, vaBad(i), vaGood(i))
        Next i

    Anglicize = sReturn
    'Sheets("Results").Activate

End Function