在 VBA 中的单列中匹配一系列行中的“文本”

Question

Dear stack overflow community:

To be brief, the goal of this program is to allow user to input text in Cell C53 and for the program to find matching text in a string in contained in each row within Column A, then return the text in column B on the same row if found (otherwise, return "Use your best judgement".)

I've successfully created the VBA code to find a matching text in a specific row in Column A and return the value in the same row in column B. However, it only works on one row hardcoded into the code. I need to adjust it to loop through a range of rows in column A because there may be matching text in other rows.

My code currently looks like this:

Sub Test_2()

Dim SearchString, SearchText

SearchKey = Range("A1")

SearchNote = Range("C53")

    If InStr(SearchNote, SearchKey) > 0 Then
        Range("C59").Value = Range("B1").Value
    Else
        Range("C59").Value = "Please use your best judgement."
    End If

End Sub

Hence, if A1 contains "limit", and I type into C53 "client wants to upgrade limit", it will return to C59 the text in B1 because it was found.

The only addition I have been trying to make is nesting what I currently have into a loop to check other rows in Column A. For example, if A1 was "cheque" and A2 was "limit", my current code would only check A1 and not find a match resulting in the prompt "Please use your best judgement." It should be able to check A1, A2, A3 ... A50 ...

I've been having difficulties translating this to code in VBA, and was hoping for some assistance.

Answer 1

Find Word in Sentence

• The 1st code goes into a standard module eg Module1 . Only run the 1st procedure which is calling the 2nd procedure when needed.

• Adjust the const ants as you see fit. If this is used in one worksheet only then you have to change srcName and tgtName to the same string.

• To automate this, copy the second short code to the sheet module (eg Sheet1 ) worksheet where the Answer and Question Cells are. Then you run nothing, it's automatic.

Standard Module eg Module1

Option Explicit

Public Const queCell As String = "C53"               ' Question Cell

Sub writeAnswer()

    ' Data
    Const srcName As String = "Sheet1"               ' Source Worksheet Name
    Const srcFirstRow As Long = 1                    ' Source First Row Number
    Const srcLastRowCol As String = "A"              ' Source Last Row Column ID
    Dim Cols As Variant: Cols = Array("A", "B")  ' Source Column IDs
    ' Target
    Const tgtName As String = "Sheet1"               ' Target Worksheet Name
    Const ansCell As String = "C59"                  ' Answer Cell
    ' Other
    Const msg As String = "Please use your best judgement." ' Not Found Message
    Dim wb As Workbook: Set wb = ThisWorkbook ' The workbook with this code.
    
    ' Define column range.
    Dim src As Worksheet: Set src = wb.Worksheets(srcName)
    Dim rng As Range
    Set rng = src.Columns(srcLastRowCol).Find("*", , xlValues, , , xlPrevious)
    If rng Is Nothing Then Exit Sub
    If rng.Row < srcFirstRow Then Exit Sub
    Set rng = src.Range(src.Cells(srcFirstRow, srcLastRowCol), rng)

    ' Write values from column range to jagged array (Data(0) & Data(1)).
    Dim ubc As Long: ubc = UBound(Cols)
    Dim Data As Variant: ReDim Data(ubc)
    Dim j As Long
    For j = 0 To ubc
        getRange(Data(j), rng.Offset(, src.Columns(Cols(j)).Column _
                                          - src.Columns(srcLastRowCol).Column))
        If IsEmpty(Data) Then Exit Sub
    Next

    ' Search Data(0) Array for string contained in Question Cell
    ' and write result from Data(1) Array to Answer Cell.
    Dim tgt As Worksheet: Set tgt = wb.Worksheets(tgtName)
    Dim Sentence As String: Sentence = tgt.Range(queCell).Value
    Dim i As Long
    For i = 1 To UBound(Data(0))
        If Sentence = "" Then Exit For
        If Trim(Data(0)(i, 1)) <> "" Then
            If InStr(1, Sentence, Trim(Data(0)(i, 1)), vbTextCompare) > 0 Then
                tgt.Range(ansCell).Value = Data(1)(i, 1)
                Exit Sub
            End If
        End If
    Next i
    
    ' If string not found, write Not Found Message to Answer Cell.
    tgt.Range(ansCell).Value = msg

End Sub

' Writes the values of a range to a 2D one-based array.
Sub getRange(ByRef Data As Variant, DataRange As Range)
    
    Data = Empty
    If DataRange Is Nothing Then Exit Sub
    
    If DataRange.Rows.Count > 1 Or DataRange.Columns.Count > 1 Then
        Data = DataRange.Value
    Else
        ReDim Data(1 To 1, 1 To 1): Data(1, 1) = DataRange.Value
    End If
    
End Sub

Sheet Module eg Sheet1

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Me.Range(queCell), Target) Is Nothing Then
        writeAnswer
    End If
End Sub