问题描述
尊敬的堆栈溢出社区：
简而言之，该程序的目标是允许用户在单元格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