在excel中加速循環

Question

我有一些很好的幫助，讓這個搜索工具在Excel中工作，但我想知道是否有提高速度的空間。我做了一些研究，以及我對VB的理解，因爲我認爲最好的方法是使用UBOUND（array）。 '爲每個'會更快？我想知道是否有辦法隔離當前工作表中的記錄，或者它是否已經在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.使用比小區的其他方法迭代

如果能實現這個方法，我將結合上述使用它。

通常我會建議使用.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 

然後，把Anglicize版本到工作表。

ActiveSheet.UsedRange.Value = vaDataCopy 

然後，代替For i =... For j =...循環，使用uRange對象上的.Find和.FindNext方法。

這裏是一個example of how I implement 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