VBA查找与Excel指定区域匹配度最高的条件分组，代码异常求解

原代码核心问题 #

• 匹配计数iMatch没有在切换分组时重置，会把前一组的匹配数累加到后一组，导致结果完全失真
• 没有存储每个分组的匹配数，运行完逻辑也无法判断哪组匹配度最高
• 缺少最终结果输出逻辑，程序运行后没有任何反馈

修正后可直接运行的代码 #

Sub Get_the_relevant_group()
    Dim wb As Workbook
    Dim sh As Worksheet
    Dim searchList As Variant
    Dim searchVal As Variant, val2check As Variant
    Dim rng2check As Range
    Dim cell2check As Range
    Dim iMatch As Integer
    ' 新增变量：存储各分组匹配数、分组名称、最高匹配数、最优分组索引
    Dim matchCount(1 To 4) As Integer
    Dim groupNames(1 To 4) As String
    Dim maxMatch As Integer, bestGroup As Integer
    Dim iCol As Integer, iGroup As Integer, i As Integer
    
    Set wb = ActiveWorkbook
    ' 若固定校验Sheet1可修改为 Set sh = wb.Sheets("Sheet1")
    Set sh = wb.ActiveSheet
    
    iCol = sh.Cells(1, Columns.Count).End(xlToLeft).Column
    Set rng2check = sh.Range(sh.Cells(1, 1), sh.Cells(1, iCol))

    ' 初始化分组名称
    groupNames(1) = "GroupA"
    groupNames(2) = "GroupB"
    groupNames(3) = "GroupC"
    groupNames(4) = "GroupD"
    
    GroupA = Array("Apple", "Banana", "Coconut", "Grape", "Orange", "Guava", "Durian", _
         "Blackcurrent", "Mango", "Strawberry")
    GroupB = Array("Apple", "Coconut", "Guava", "Mango", "Strawberry", "Lime", "Grape", "Pear", "Blueberry", "Lemon")
    GroupC = Array("Apple", "Grape", "Durian", "Pineapple", "Watermelon", "Blueberry", "Banana", "Lemon")
    GroupD = Array("Apple", "Orange", "Lime", "Plums", "Pear", "Lemon", "Coconut", "Grape")
        
    For iGroup = 1 To 4
        ' 每轮分组校验前重置匹配计数
        iMatch = 0
        Select Case iGroup
            Case 1: searchList = GroupA
            Case 2: searchList = GroupB
            Case 3: searchList = GroupC
            Case 4: searchList = GroupD
        End Select
        
        For Each cell2check In rng2check
            If cell2check <> "" Then
                val2check = cell2check.Value
                For Each searchVal In searchList
                    ' 加vbTextCompare参数实现不区分大小写匹配
                    If InStr(1, val2check, searchVal, vbTextCompare) > 0 Then
                        iMatch = iMatch + 1
                        Exit For
                    End If
                Next searchVal
             End If
        Next cell2check
        ' 存储当前分组的匹配数量
        matchCount(iGroup) = iMatch
    Next iGroup
    
    ' 查找匹配度最高的分组
    maxMatch = 0
    bestGroup = 1
    For i = 1 To 4
        If matchCount(i) > maxMatch Then
            maxMatch = matchCount(i)
            bestGroup = i
        End If
    Next
    
    ' 弹窗输出最终结果
    MsgBox "匹配度最高的分组为：" & groupNames(bestGroup) & vbCrLf & "匹配数量：" & maxMatch & "个"
End Sub

可选调整说明 #

如果需要完全匹配水果名称，避免出现单元格内容是Pineapple匹配到Apple的误判，可将InStr(1, val2check, searchVal, vbTextCompare) > 0替换为UCase(val2check) = UCase(searchVal)即可。

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