Excel VBA查找函数耗时较长

我编写了一个短函数，用于在Excel工作簿中搜索一组字符串和另一组字符串。功能如下：

    Function CheckForString(Target As Range, List As Range)

    Application.ScreenUpdating = False

    Dim Output As String
    Output = "No Match"


    For Each Item In List

        If Output = "No Match" Then
            If Not Target.Find(Item.Value) Is Nothing Then Output = Item.Value
        End If

    Next

    CheckForString = Output

    Application.ScreenUpdating = True


    End Function

问题是，我使用这个函数在大约400000个字符串中搜索大约2000个其他字符串中的任何一个。我已经设置好了，让它运行几个小时，但它还没有完成计算

因此，工作表中有400000个=CheckForString（）实例，它们在~2000个单元格范围内循环。我需要做的就是看看2000中的任何字符串是否出现在400000个单元格中。例如：

字符串：“苹果-香蕉123459”

要查找的字符串：

苹果香蕉

苹果香蕉

因此，如果它“命中”第一个，我不在乎它是否找到更多。我只需要知道至少有一个字符串在里面

感谢您对如何加快速度的任何想法

最好的

格洛林斯

编辑：回复评论中到目前为止的问题（感谢您抽出时间！）

我正在搜索的数据是包含序列号（字母数字）的字符串，但格式不一致，包括额外的垃圾、空白、其他字符等

我有一组原始的序列号，我正试图将其与大型数据转储进行比较。目标是确定大型集合中的哪些字符串包含可能是列表中序列号的字符串，以便我可以进一步查看这些记录并使用它们创建报告

我希望这能让事情变得更清楚一点！再次感谢

---

我也要试试出口。如果有什么的话，也许它会剃掉几个小时

子例程

MarkStrings

将以绿色突出显示

Target

中的所有字符串，这些字符串包含

列表

范围中的子字符串

主要思想是：

• 以简单的数据结构“在堆栈内存上”工作
• 避免重复转换同一项目
• 使用

  字符串

  函数，而不是

  工作表函数

  函数（同样，速度要快得多）

当然，您可以将

子项

重新指定用途以执行您想要的操作。请注意，与您的

函数不同。当为许多单元格调用函数时，此子例程应调用一次，对于所有
目标
范围，请参见
Test（）
子例程

    Public Sub Test()

            Call MarkStrings(Sheet1.Range("C3:DG303"), Sheet1.Range("A1:B2"))

    End Sub


    Public Sub MarkStrings( _
       ByVal Target As Range, _
       ByVal List As Range _
    )

            Dim raw           As Variant
            Dim str_target()  As String
            Dim str_list()    As String

            Dim m As Long, m_min As Long, m_max As Long
            Dim n As Long, n_min As Long, n_max As Long
            Dim p As Long, p_min As Long, p_max As Long
            Dim q As Long, q_min As Long, q_max As Long

            ' 0. Check ranges '
            If (Target Is Nothing) Or (List Is Nothing) Then
                    Exit Sub
            End If

            Let Application.ScreenUpdating = False

            ' 1. Load the entire Target in memory, and make it string '
            Let raw = Target.Value

            Let m_min = LBound(raw, 1)
            Let m_max = UBound(raw, 1)
            Let n_min = LBound(raw, 2)
            Let n_max = UBound(raw, 2)

            ReDim str_target( _
               m_min To m_max, _
               n_min To n_max _
            )
            For m = m_min To m_max
            For n = n_min To n_max
                    Let str_target(m, n) = CStr(raw(m, n))
            Next n
            Next m

            Let raw = Empty

            ' 2. Load the entire List in memory, and make it string '
            Let raw = List.Value

            Let p_min = LBound(raw, 1)
            Let p_max = UBound(raw, 1)
            Let q_min = LBound(raw, 2)
            Let q_max = UBound(raw, 2)

            ReDim str_list( _
               p_min To p_max, _
               q_min To q_max _
            )
            For p = p_min To p_max
            For q = q_min To q_max
                    Let str_list(p, q) = CStr(raw(p, q))
            Next q
            Next p

            Let raw = Empty


            ' 3. Loop trough Target and check elements in List. If found, '
            '    make cell background green and go to next target.        '
            For m = m_min To m_max
            For n = n_min To n_max
                    For p = p_min To p_max
                    For q = q_min To q_max
                            If Strings.InStr( _
                               Start:=1, _
                               String1:=str_target(m, n), _
                               String2:=str_list(p, q), _
                               Compare:=vbTextCompare _
                            ) > 0 Then
                                    Let Target.Cells(m, n).Interior.Color = vbGreen
                                    GoTo NEXT_TARGET
                            End If
                    Next q
                    Next p
    NEXT_TARGET:
            Next n
            Next m

            Let Application.ScreenUpdating = True

    End Sub

在我的机器上搜索大约300×100范围内的4个字符串花费了一秒钟。对于您的情况，应该需要（400000×2000）/（4×30000）~=6700秒~=2小时。
近似，但我不明白为什么不使用range.find方法。这种情况下，目标范围可能有40000行，需要搜索近2000行。使用find循环将只需要2000次。并且只需几秒钟就能得到结果，代码速度会快得多

Function myfind(targetrng As Range, sourcerng As Range)

On Error Resume Next

Dim c As Range
Dim cell As Range


    Set c = targetrng.Find(what:=cell.Value, LookIn:=xlValues, lookat:=xlPart, searchorder:=xlByRows, searchdirection:=xlNext)

    If c Is Nothing Then
            myfind = "No Match"
        Else
            myfind = "Match Found"
    End If


End Function

您能否更详细地描述业务需求和所需的输出？您可以在If语句中插入“Exit For”，以避免在遇到第一个匹配项时继续循环。这并不能解决你所有的问题，但这只是一个开始。听起来在你试图找出问题的症结之前，最好重新组织你的数据（结构）；我在帖子中添加了一些附加信息！随着“退出”的增加，我实际上得到了一个正在移动的计算百分比，这是有希望的！看起来它仍然走在一条可以走一整天的路上。谢谢！我在考虑用数组重新实现，而不是创建一个工作表函数。我创建了与上面类似的东西，它似乎运行得更快。事实上，我在宏中加入了一点脚本，每15分钟启动一个消息框，这样我就可以看到它在这个范围内进展了多远。它甚至没有达到15分钟。这个过程大约在4分钟内完成。@grrollins哇，这是我对代码性能感到悲观的少数情况之一；我应该经常这样做。：-）+1：很好的优化！我可能会使用藏书或字典，但这样做应该很好。@Nanashi谢谢你的夸奖。：-）我也考虑过
VBA.Collection
，但问题是，您需要查找子字符串，而不是整个字符串，因此您不能使用
List
中的键来标识
Target
内容集合中的元素。您可以在工作表中使用此函数作为“=myfind（targetrng，sourcerng）”每2000行的结果为“找到匹配项或未找到匹配项”