Question

Public Function FindCodes(keywords As Range, text As String)
    'FindCodes = "TEST"

    Dim codeRows As Collection
    Dim codeString As String
    Set codeRows = New Collection

    'Find Codes
    For Each Item In keywords
        Dim keywordArr() As String
        Dim i As Integer
        i = 0
        If Item.Row <> 1 Then 'Ignore first row
            keywordArr() = Split(Item, ",")
            'On Error Resume Next
            On Error GoTo ErrHandler
            For Each s In keywordArr()
                If InStr(LCase(text), LCase(s)) <> 0 Then
                    codeRows.Add Item.Row, CStr(Item.Row)
                End If
            Next s
        End If
    Next Item

    'Build Codes String
    If codeRows.Count > 0 Then
        Dim codeArr() As String
        'Set codeArr = New Collection
        'Dim i As Integer
        'i = 0
        ReDim codeArr(codeRows.Count)
        For Each s In codeRows
            'codeArr.Add s, CStr(Worksheets("Codes").Range("A" & s).Value)
            codeArr(i) = Worksheets("Codes").Range("A" & s).Value
            'Set i = Worksheets("Codes").Range("B" + s).Value
            i = i + 1
        Next s
    End If

    'FindCodes = Join(codeArr, ",")

    If UBound(codeArr) > 1 Then
        FindCodes = Join(codeArr, ",")
    ElseIf UBound(codeArr) = 1 Then
        FindCodes = codeArr(0)
    Else
        FindCodes = ""
    End If

ErrHandler:
    If Err.Number = 457 Or Err.Number = 0 Or Err.Number = 20 Then
        'foo = someDefaultValue
        Resume Next
    Else
        'Err.Raise Err.Number
        FindCodes = CVErr(xlErrValue)
    End If

End Function

Sub temp()
    Dim r As Range
    Set r = Worksheets("Codes").Range("B:B")
    MsgBox FindCodes(r, ".")
End Sub

Answer 1

您的代码似乎过于复杂，但是也许我误解了它应该做什么。

尝试一下：

Public Function FindCodes(keywords As Range, text As String)

    Dim c As Range, keywordArr, s, rv

    'only look at used cells
    Set keywords = Application.Intersect(keywords, keywords.Worksheet.UsedRange)

    For Each c In keywords.Cells
        If c.Row > 1 And Len(c.Value) > 0 Then 'Ignore first row and empty cells
            keywordArr = Split(c.Value, ",")
            For Each s In keywordArr
                If LCase(Trim(s)) = LCase(Trim(text)) Then
                    'grab value from ColA and go to next cell
                    rv = rv & IIf(Len(rv) = 0, "", ",") & c.EntireRow.Cells(1).Value
                    Exit For
                End If
            Next s
        End If
    Next c
    FindCodes = rv
End Function

需要稍微调整一下此代码...需要它来找到完全匹配的内容，我不在同盟之列

1 个答案: