vba 在excel中加速循环

Speed up loop in excel

提问by cbrannin

I had some great help to get this search tool working in excel but I was wondering if there is room for speed improvement. I did some research and with what little I understand about VB for i = LBOUND(array) To UBOUND(array) seems most optimal. Would 'For Each' be faster? I am wondering if there is a way to isolate the records currently in the worksheet, or if it is already doing this with L/UBOUND? If it is, is there a way to do 'ignore special characters' similar to SQL? After adding screenupdating and calculation, I was able to shave about 10 seconds off of the total run time. And further I was using FormulaR1C1 for my search before this new loop and it would limit the amount of columns to search while being super fast.

我得到了一些很大的帮助，让这个搜索工具在 excel 中工作，但我想知道是否有提高速度的空间。我做了一些研究，我对 VB for i = LBOUND(array) To UBOUND(array) 的了解似乎是最优化的。“For Each”会更快吗？我想知道是否有办法隔离工作表中当前的记录，或者是否已经使用 L/UBOUND 执行此操作？如果是，有没有办法像 SQL 那样“忽略特殊字符”？添加 screenupdating 和计算后，我能够将总运行时间缩短大约 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

Any help or recommendations are greatly appreciated.

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

    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

回答by David Zemens

Ultimately, the execution speed here is severely hampered by the apparent requirement to operate on everycell in the range, and because you're asking about performance, I suspect this range may contain many thousands of cells. There are two things I can think of:

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

1. Save your results in an array and write to the Results worksheet in one statement

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

Try replacing this:

尝试替换这个：

'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

With a statement that assigns the value Application.Index(vaData, i, 0)to an array variable, and then when you're completed the For iloop, you can write the results in one pass to the results worksheet.

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

NOTEThis may be noticeably faster if and only if there are many thousands of results. If there are only a few results expected, then exeuction speed is primarily affected by the need to iterate over every cell, not the operation of writing the results to another sheet.

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

2. Use another method than cell iteration

2. 使用细胞迭代以外的其他方法

If you can implement this method, I would use it in conjunction with the above.

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

Ordinarily I would recommend using the .Findand .FindNextmethods as considerably more efficient than using the i,jiteration. But since you need to use the AnglicizeUDF on every cell in the range, you would need to make some restructure your code to accommodate. Might require multiple loops, for example, first Anglicizethe vaDataand preserve a copy of the non-Anglicized data, like:

通常我会建议使用.Find和.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

Then, put the Anglicizeversion on to the worksheet.

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

ActiveSheet.UsedRange.Value = vaDataCopy

Then, instead of the For i =... For j =...loop, use the .Findand .FindNextmethod on the uRangeobject.

然后，在对象上For i =... For j =...使用.Findand.FindNext方法而不是循环uRange。

Here is an example of how I implement Find/FindNext.

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

Finally, put the non-Anglicized version back on the worksheet, again with the caveat that it might require use of Transposefunction:

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

ActiveSheet.UsedRange.Value = vaData

Whil this still iterates over every value to perform the Anglicizefunction, it does not operate on every value a second time (Instrfunction). So, you're essentially operating on the values only once, rather than twice. I suspect this should be much faster, especially if you combine it with the #1 above.

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

UPDATE BASED ON OP REVISION EFFORTS

基于 OP 修订工作的更新

After some comment discussion & emails back and forth, we arrive at this solution:

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

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("?,?,?,?,?,à,á,?,?,?,?,?,è,é,ê,?,ì,í,?,?,D,?,ò,ó,?,?,?,ù,ú,?,ü,Y,à,á,a,?,?,?,?,è,é,ê,?,ì,í,?,?,e,?,ò,ó,?,?,?,ù,ú,?,ü,y,?", ",")
    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