在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