Excel多列匹配查找并高亮指定字符数内完全/部分匹配值求助

前置操作 #

• 运行代码前同时打开Source File（源文件）和Working File（工作文件）
• 确认源文件内所有黑名单机构名称存放在同一列，记住对应的工作表名、列号、起始行号（跳过表头行）
• 提前确定部分匹配的判定规则：即两个名称有多少个连续字符重合就算匹配命中，比如设置3代表连续3个字符一致就算命中

可用VBA代码 #

Sub 黑名单高亮匹配()
    ' ------------ 以下为可修改参数，根据你的实际情况调整 ------------
    Const 源文件全称 As String = "Source File.xlsx" ' 源文件完整名称，带后缀
    Const 源文件工作表名 As String = "Sheet1" ' 源文件存黑名单的工作表名称
    Const 黑名单所在列 As String = "A" ' 黑名单存储的列号
    Const 黑名单起始行 As Long = 2 ' 黑名单第一条内容所在行（跳过表头）
    Const 工作文件工作表名 As String = "Sheet1" ' 工作文件要处理的工作表名称
    Const 最小匹配字符数 As Integer = 3 ' 部分匹配要求的连续重合最小字符数
    ' ------------ 参数修改结束 ------------
    
    Dim 黑名单数组 As Variant
    Dim i As Long, j As Long, k As Long, l As Long
    Dim 单元格内容 As String, 黑名单项 As String
    Dim 匹配遍历长度 As Integer
    
    ' 读取全部黑名单到数组，提升运行效率
    黑名单数组 = Workbooks(源文件全称).Sheets(源文件工作表名).Range(黑名单所在列 & 黑名单起始行 & ":" & 黑名单所在列 & Workbooks(源文件全称).Sheets(源文件工作表名).Cells(Rows.Count, 黑名单所在列).End(xlUp).Row).Value
    
    ' 遍历工作文件前11列所有有内容的单元格
    For i = 1 To ThisWorkbook.Sheets(工作文件工作表名).Cells(Rows.Count, 1).End(xlUp).Row
        For j = 1 To 11
            单元格内容 = Trim(ThisWorkbook.Sheets(工作文件工作表名).Cells(i, j).Value)
            If 单元格内容 <> "" Then
                ' 清除之前的高亮标记，不需要可删除下行
                ThisWorkbook.Sheets(工作文件工作表名).Cells(i, j).Interior.ColorIndex = xlNone
                ' 遍历所有黑名单匹配
                For k = 1 To UBound(黑名单数组, 1)
                    黑名单项 = Trim(黑名单数组(k, 1))
                    If 黑名单项 <> "" Then
                        ' 完全匹配判定
                        If 单元格内容 = 黑名单项 Then
                            ThisWorkbook.Sheets(工作文件工作表名).Cells(i, j).Interior.Color = RGB(255, 0, 0)
                            Exit For
                        End If
                        ' 部分匹配判定
                        If Len(单元格内容) >= 最小匹配字符数 And Len(黑名单项) >= 最小匹配字符数 Then
                            匹配遍历长度 = Len(单元格内容) - 最小匹配字符数 + 1
                            For l = 1 To 匹配遍历长度
                                If InStr(黑名单项, Mid(单元格内容, l, 最小匹配字符数)) > 0 Then
                                    ThisWorkbook.Sheets(工作文件工作表名).Cells(i, j).Interior.Color = RGB(255, 0, 0)
                                    Exit For
                                End If
                            Next l
                            If ThisWorkbook.Sheets(工作文件工作表名).Cells(i, j).Interior.Color = RGB(255, 0, 0) Then Exit For
                        End If
                    End If
                Next k
            End If
        Next j
    Next i
    MsgBox "匹配处理完成，命中单元格已标红"
End Sub

使用步骤 #

• 打开工作文件，按Alt + F11调出VBA编辑器
• 右键左侧工程列表里的工作文件名称，依次选择「插入」-「模块」
• 将上述代码粘贴到弹出的空白模块窗口
• 修改代码开头的自定义参数，和你的实际文件配置对齐
• 按F5运行即可

注意事项 #

• 运行前务必保存两个文件的内容，避免操作失误丢失数据
• 如果不需要部分匹配功能，把最小匹配字符数设置为999即可只执行完全匹配逻辑
• 如果你的文件是.xls格式，把代码里的源文件全称后缀改成.xls即可

内容的提问来源于stack exchange，提问作者Yusuf Ali Nalwala