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

如何解决在VBA的单列中匹配行中的“文本”

尊敬的堆栈溢出社区：

简而言之，该程序的目标是允许用户在单元格C53中输入文本，并使该程序在A列的每一行中包含的字符串中找到匹配的文本，然后如果找到，则返回同一行的B列中的文本（否则，返回“使用您的最佳判断”。）

我已经成功创建了VBA代码，以在A列的特定行中找到匹配的文本，并在B列的同一行中返回值。但是，它仅适用于硬编码到代码中的一行。我需要对其进行调整以遍历A列中的一系列行，因为其他行中可能有匹配的文本。

我的代码当前如下所示：

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

因此，如果A1包含“限制”，而我在C53中键入“客户希望升级限制”，则它将被发现，因为它已找到。B1中的文本将返回C59。

我一直想做的唯一添加就是将当前当前的内容嵌套到循环中以检查A列中的其他行。例如，如果A1是“ cheque”而A2是“ limit”，那么我当前的代码只会检查A1并没有找到匹配项，并提示“请使用最佳判断”。它应该能够检查A1，A2，A3 ... A50 ...

我一直很难将其转换为VBA中的代码，并希望获得一些帮助。

解决方法

在句子中查找单词

• 第一个代码进入标准模块，例如Module1。仅在需要时运行正在调用第二过程的第一过程。

• 根据需要调整 const 蚂蚁。如果仅在一个工作表中使用它，则必须将srcName和tgtName更改为相同的字符串。

• 要自动执行此操作，请将第二个短代码复制到工作表模块（例如Sheet1）工作表中的答案和问题单元格所在的位置。然后，您什么也不运行，这是自动的。

标准模块，例如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
        Call 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

工作表模块，例如Sheet1

Option Explicit

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