Excel VBA 在单元格中搜索文本，如果找到，将文本放入另一个单元格

Question

我有一个简单的工作表，有 4 个主要列：日期、项目、金额、客户。

项目列是从一个系统填充的，该系统提供中间带有特定单词的垃圾文本。示例：“00x1500s544v Client1 1158ec5”。假设我无法获得干净的数据。

我有 20 多个客户的名单。我希望 VB 从“项目”单元格中的 20+ 个列表中搜索客户名称，如果找到，则在名为“客户”的另一列中返回客户名称。客户列表位于另一个名为“客户”的选项卡中。我们将此选项卡称为“记录”。有时项目单元格中没有客户名称，在这种情况下，我们在客户单元格中输入“不是客户”。

我们的工作流程是将一个文件（通过电子邮件发送给我们）中的数据复制并粘贴到该文件中。因此，从源电子邮件文件中复制 A-D 并将其粘贴到运行列表底部的目标文件中。复制/粘贴后，我们希望代码检查新记录（或所有记录，如果更容易的话）并使用客户名称更新客户列。

谢谢

我在 StackOverFlow 上找到了这段代码，它可以工作，但前提是存在完全匹配。它不会在文本字符串内搜索。

使用测试工作表

Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Me.Range("b:b")) Is Nothing Then
FillConversion
End If
End Sub

Sub FillConversion()

Const FirstRow = 3
Const SourceCol = "B"
Const TargetCol = "G"

Dim CurRow As Long
Dim LastRow As Long

Application.ScreenUpdating = False
LastRow = Range(SourceCol & Rows.Count).End(xlUp).Row

For CurRow = FirstRow To LastRow
    Select Case Cells(CurRow, SourceCol).Value
        
        Case "Client1"
        Cells(CurRow, TargetCol).Value = "Client1"
        
        'add the other client cases here...

    End Select
Next CurRow

Application.ScreenUpdating = True

End Sub

Answer 1

请尝试

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim r As Range: Set r = Intersect(Target, Me.Range("B:B"))
    If Not r Is Nothing Then
        Application.EnableEvents = False
        Dim arrList ' load Client list
        arrList = Sheets("Client").Range("A1").CurrentRegion.Value
        Dim arrB: ' load input
        arrB = IIf(r.Count = 1, Array(r.Value), Application.Transpose(r.Value))
        Dim arrG: arrG = arrB
        Dim i As Long, j As Long
        For i = LBound(arrB) To UBound(arrB)
            If Len(Trim(arrB(i))) = 0 Then
                arrG(i) = ""
            Else
                arrG(i) = "Not a Client"
                For j = LBound(arrList) + 1 To UBound(arrList) ' remove +1 if there isn't header row in client list table
                    If InStr(1, Chr(32) & arrB(i) & Chr(32), _
                        Chr(32) & arrList(j, 1) & Chr(32), vbTextCompare) > 0 Then
                        arrG(i) = arrList(j, 1)
                        Exit For
                    End If
                Next j
            End If
        Next i
        ' write client to Col G
        r.Offset(0, 5).Value = Application.Transpose(arrG)
        Application.EnableEvents = True
    End If
End Sub