Excel VBA需求：在单元格文本中匹配客户名并填充对应列

需求说明 #

• 工作表Records包含Date、Item、Amount、Client四列
• Item列数据为夹杂客户名的冗余文本（示例：00x1500s544v Client1 1158ec5）
• 独立的Client工作表存储20+客户名单
• 实现逻辑：扫描Item单元格文本，若包含Client表中的客户名，将该客户名填入对应Client列单元格；未匹配到则填入Not a Client
• 触发时机：将外部文件A-D列数据粘贴至Records表末尾后，执行代码更新Client列
• 原代码仅支持精确匹配，无法处理客户名嵌入冗余文本的场景，需优化

原代码问题 #

原代码通过Select Case做精确匹配，仅能识别Item单元格内容完全等于客户名的情况，无法适配客户名夹杂在其他文本中的需求。原代码如下：

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

优化后的代码 #

以下代码读取Client工作表的客户名单，实现文本包含匹配，同时优化运行效率：

Sub UpdateClientColumn()
    ' 常量定义
    Const RECORDS_SHEET As String = "Records"
    Const CLIENT_SHEET As String = "Client"
    Const FIRST_ROW As Long = 3 ' Records表数据起始行
    Const ITEM_COL As String = "B" ' Item列
    Const CLIENT_TARGET_COL As String = "D" ' Client列（根据实际需求调整）
    
    Dim wsRecords As Worksheet, wsClient As Worksheet
    Dim clientArr As Variant
    Dim lastRowRecords As Long, lastRowClient As Long
    Dim i As Long, j As Long
    Dim itemText As String
    Dim clientFound As Boolean
    
    ' 关闭屏幕更新，提升运行速度
    Application.ScreenUpdating = False
    
    ' 初始化工作表对象
    Set wsRecords = ThisWorkbook.Worksheets(RECORDS_SHEET)
    Set wsClient = ThisWorkbook.Worksheets(CLIENT_SHEET)
    
    ' 获取客户名单并存储到数组（减少工作表访问次数）
    lastRowClient = wsClient.Cells(wsClient.Rows.Count, 1).End(xlUp).Row
    clientArr = wsClient.Range("A1:A" & lastRowClient).Value ' 假设客户名单在Client表A列
    
    ' 获取Records表最后一行
    lastRowRecords = wsRecords.Cells(wsRecords.Rows.Count, ITEM_COL).End(xlUp).Row
    
    ' 遍历Records表的Item列
    For i = FIRST_ROW To lastRowRecords
        itemText = wsRecords.Cells(i, ITEM_COL).Value
        clientFound = False
        
        ' 遍历客户名单，检查是否包含
        For j = 1 To UBound(clientArr)
            If InStr(1, itemText, clientArr(j, 1), vbTextCompare) > 0 Then ' 不区分大小写匹配
                wsRecords.Cells(i, CLIENT_TARGET_COL).Value = clientArr(j, 1)
                clientFound = True
                Exit For ' 找到匹配后退出循环，提升效率
            End If
        Next j
        
        ' 未找到匹配客户
        If Not clientFound Then
            wsRecords.Cells(i, CLIENT_TARGET_COL).Value = "Not a Client"
        End If
    Next i
    
    ' 恢复屏幕更新
    Application.ScreenUpdating = True
    MsgBox "Client列更新完成", vbInformation
End Sub

' 可选：粘贴后自动触发（按需启用）
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim wsRecords As Worksheet
    Set wsRecords = ThisWorkbook.Worksheets("Records")
    
    ' 仅当粘贴到Records表的A-D列时触发
    If Not Intersect(Target, wsRecords.Range("A:D")) Is Nothing Then
        UpdateClientColumn
    End If
End Sub

代码说明 #

• 客户名单数组化：将Client表的客户名单读取到数组中，避免循环中反复访问工作表，大幅提升运行效率
• 包含匹配逻辑：使用InStr函数检查Item文本是否包含客户名，支持不区分大小写匹配（可通过修改vbTextCompare为vbBinaryCompare改为区分大小写）
• 自动识别范围：自动识别Records表和Client表的最后数据行，无需手动调整范围
• 可选自动触发：通过Worksheet_Change事件，在粘贴数据到Records表A-D列时自动执行更新逻辑
• 屏幕更新控制：关闭屏幕更新避免界面闪烁，完成后恢复

内容的提问来源于stack exchange，提问作者jrdidigetthis