VBA中Find/FindNext无法匹配含换行符的字符串问题求助

背景与问题 #

数据表A列存储不唯一的tagcode（标签码），一个tagcode对应多条记录。需编写VBA UDF（用户定义函数）获取指定tagcode的所有相关记录，但常规的Find/FindNext方法无法稳定工作：有时仅找到1条记录、有时找不到、有时仅找到部分，偶尔才能匹配全部。

特殊情况：tagcode中常包含Chr(10)（换行符），这可能是问题根源。直接在Excel工作表中使用查找功能，能正常找到所有匹配记录，且该函数是作为UDF从数据表中调用的（当前行的tagcode至少能匹配自身记录）。

初始函数代码 #

Function KabelTrajectInfo(kabelCell As Range) As String
    
    Dim rij As Integer
    rij = kabelCell.Row
    
    Dim KcellCol As New Collection
    Dim Kcell As Range
    Dim firstRow As Long
    Dim tagcode As String

    tagcode = kabelCell.EntireRow.Cells(1, 1).Text '也尝试过.Value和.Formula
    
    With Intersect(Sheets("Kabels").Range("A:A"), Sheets("Kabels").UsedRange)
        If tagcode = "" Then
            Set Kcell = kabelCell.EntireRow.Cells(1, 1)
        Else
            '查找：也尝试过LookIn:=xlFormulas和xlFormulas2
            Set Kcell = .Find(What:=tagcode, _
                After:=.Cells(1, 1), LookIn:= _
                xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:= _
                xlNext, MatchCase:=True, SearchFormat:=False)

            '奇怪：有时找不到，所以用Match检查：这个总能找到第一条匹配行
            If Kcell Is Nothing Then 
                firstRow = Application.WorksheetFunction.Match(tagcode, .Cells, 0)
                If firstRow = 0 Then
                    Set Kcell = kabelCell.EntireRow.Cells(1, 1)
                Else
                    Set Kcell = Sheets("Kabels").Cells(firstRow, 1)
                End If
            End If
        End If
        firstRow = Kcell.Row
        
        While Not Kcell Is Nothing
            KcellCol.Add Item:=Kcell

            '最初的逻辑方案：用FindNext永远找不到下一条
            Set Kcell = .FindNext(Kcell)

            '备用方案：用Find并自行检查防止循环：有时能找到其他记录，但经常找不全或漏最后一条
            If tagcode <> "" Then Set Kcell = .Find(What:=tagcode, After:=Kcell, LookIn:=xlValues, _
                LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:= _
                xlNext, MatchCase:=True, SearchFormat:=False)
            If Not Kcell Is Nothing Then
                If Kcell.Row = firstRow Then Set Kcell = Nothing
            End If
        Wend
    End With
    
    For Each Kcell In KcellCol
    ... '生成tempStr的代码
    Next Kcell

    KabelTrajectInfo = tempStr
End Function

测试的替代方法及结果 #

为解决问题，测试了以下几种替代方法：

测试代码 #

Private Function getTagcodeCol2(tagcode As String) As Collection
    Dim tempCol As New Collection
    Dim c As Range
    
    For Each c In Intersect(Sheets("Kabels").Range("A:A"), Sheets("Kabels").UsedRange())
        If c.Text = tagcode Then tempCol.Add Item:=c
    Next c
    
    Debug.Print tagcode, tempCol.Count
    Set getTagcodeCol2 = tempCol
End Function
 
Private Function getTagcodeCol(tagcode As String) As Collection
    Dim KcellArr  As Variant
    Dim lastrow As Long
    lastrow = Sheets("Kabels").UsedRange.Rows.Count
    
    KcellArr = Application.Evaluate("FILTER(ROW(Kabels!A1:A" & lastrow & "),A1:A" & lastrow & "=\"\"" & tagcode & "\"\" ,\"\"\"\" ")")
    
    Dim tempCol As New Collection
    Dim tel As Long
    '无错误检查，因为数组维度变化：找到1条是一维数组，多条是二维数组
    On Error Resume Next
    For tel = 1 To UBound(KcellArr)
        tempCol.Add Item:=Sheets("Kabels").Cells(CLng(KcellArr(tel, 1)), 1)
        tempCol.Add Item:=Sheets("Kabels").Cells(CLng(KcellArr(tel)), 1)
    Next tel
    On Error GoTo 0
    
    Debug.Print tagcode, tempCol.Count
    Set getTagcodeCol = tempCol
End Function
Private Function getTagcodeCol3(tagcode As String) As Collection
    Dim KcellArr  As Variant
    Dim lastrow As Long
    
    KcellArr = Application.Evaluate("FILTER(ROW(Kabels!A:A),A:A=\"\"" & tagcode & "\"\" ,\"\"\"\" ")")
    
    Dim tempCol As New Collection
    Dim tel As Long
    '无错误检查，因为数组维度变化：找到1条是一维数组，多条是二维数组
    On Error Resume Next
    For tel = 1 To UBound(KcellArr)
        tempCol.Add Item:=Sheets("Kabels").Cells(CLng(KcellArr(tel, 1)), 1)
        tempCol.Add Item:=Sheets("Kabels").Cells(CLng(KcellArr(tel)), 1)
    Next tel
    On Error GoTo 0
    
    Debug.Print tagcode, tempCol.Count
    Set getTagcodeCol3 = tempCol
End Function
Private Function getTagcodeCol4(tagcode As String) As Variant
    Dim KcellArr  As Variant
    Dim lastrow As Long
    
    KcellArr = Application.Evaluate("FILTER(ROW(Kabels!A:A),A:A=\"\"" & tagcode & "\"\" ,\"\"\"\" ")")
    
    'If UBound(KcellArr) = 1 Then KcellArr(1) = Array(KcellArr)
        
    Debug.Print tagcode, UBound(KcellArr)
    getTagcodeCol4 = WorksheetFunction.TextJoin(",", True, KcellArr)
End Function

Sub test()
    Dim KcellCol  As Collection
    Dim KcellCol2 As Collection
    Dim KcellCol3  As Collection
    Dim KcellColStr  As String
    Dim tagcode As String
    tagcode = ActiveCell.Value
    '"LSBZ_LOTS04" & vbCr & "26 Q1_W1"
    '"DB_UPS_ROTS04_1X4_W1"
    
    Dim t1A, t1U, t2A, t2U, t3A, t3U, t4A, t4U As Variant
    Dim tel As Long
    Dim telmax As Long
    
    telmax = 200
    
    t1A = Now()
    For tel = 1 To telmax
        Set KcellCol = getTagcodeCol(tagcode)
    Next tel
    t1U = Now()
    
    t2A = Now()
    For tel = 1 To telmax
        Set KcellCol2 = getTagcodeCol2(tagcode)
    Next tel
    t2U = Now()
    
    t3A = Now()
    For tel = 1 To telmax
        Set KcellCol3 = getTagcodeCol3(tagcode)
    Next tel
    t3U = Now()
    
    t4A = Now()
    For tel = 1 To telmax
        KcellColStr = getTagcodeCol4(tagcode)
    Next tel
    t4U = Now()

    Debug.Print KcellCol.Count, KcellCol2.Count, KcellCol3.Count, UBound(Split(KcellColStr, ",")) + 1
    
    Debug.Print 24# * 3600 * (t1U - t1A), 24# * 3600 * (t2U - t2A), 24# * 3600 * (t3U - t3A), 24# * 3600 * (t4U - t4A)
    
End Sub

测试结果 #

• 仅getTagcodeCol2（遍历所有单元格匹配c.Text）始终返回正确的匹配数量
• getTagcodeCol（使用Application.Evaluate调用FILTER函数）速度比其他三种快10倍左右，但偶尔会出现匹配错误
• getTagcodeCol3和getTagcodeCol4也偶尔出错，速度与getTagcodeCol2相差约5%

求助问题 #

1. 为什么包含Chr(10)换行符的字符串，使用Find/FindNext或FILTER函数会出现匹配不稳定的情况？
2. 如何优化实现，兼顾匹配的正确性和执行速度？

内容的提问来源于stack exchange，提问作者Christof De Backere