Question

我有一些很好的帮助让这个搜索工具在excel中工作，但我想知道是否有提高速度的空间。我做了一些研究，我对VB的理解很少i = LBOUND（数组）到UBOUND（数组）似乎是最优的。会为每个＆＃39;更快？我想知道是否有办法隔离当前工作表中的记录，或者它是否已经使用L / UBOUND执行此操作？如果是，是否有办法忽略特殊字符＆＃39;类似于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 =...对象上使用.Find和.FindNext方法，而不是uRange循环。

这是example of how I implement Find/FindNext。

最后，将非Anglicized版本放回到工作表上，同样需要注意它可能需要使用Transpose函数：

ActiveSheet.UsedRange.Value = vaData

当这仍然遍历每个值以执行Anglicize函数时，它不会再次对每个值进行操作（Instr函数）。所以，你基本上只对值进行一次操作，而不是两次。我怀疑这应该快得多，特别是如果你把它与上面的＃1结合起来。

基于OP修改效果的更新

经过一些评论讨论＆amp;来回的电子邮件，我们到达这个解决方案：

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

加速excel中的循环

1 个答案: