VBA宏：获取一组条件的最大匹配单元格值

Question

我有 4 组标准要匹配。 如果要从 sheet1.range("A1:J1") 检查的范围数据包含：10 种水果。 我想知道哪个组与范围数据的匹配度最高。

例如：enter image description here

我尝试了以下代码，但不起作用：

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
    
    
    Set wb = ActiveWorkbook
    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))
    

    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
        If iGroup = 1 Then searchList = GroupA
        If iGroup = 2 Then searchList = GroupB
        If iGroup = 3 Then searchList = GroupC
        If iGroup = 4 Then searchList = GroupD
        
        For Each cell2check In rng2check
            If cell2check <> "" Then
                For Each searchVal In searchList
                    val2check = cell2check.Value
                    If InStr(1, val2check, searchVal) > 0 Then
                        iMatch = iMatch + 1
                        Exit For
                    End If
                Next searchVal
             End If
            If iMatch = iCol Then Exit For
        Next cell2check
    Next iGroup
End Sub

我希望有人能给我解决方案。非常感谢

Answer 1

这是我的做法（我已经对这些行进行了评论，以便您了解它在做什么）：

Sub Get_the_relevant_group()

Dim ws As Worksheet, SearchArr, SearchString As String, i As Long, j As Long
Dim iGroup, iMatch As Long, iCounter As Long, iCol As Long

Set ws = ThisWorkbook.ActiveSheet

iCol = ws.Cells(1, Columns.Count).End(xlToLeft).Column
'Below turns the search list into a 1d array
SearchArr = Application.Transpose(Application.Transpose(ws.Range(ws.Cells(1, 1), ws.Cells(1, iCol)).Value))
SearchString = Join(SearchArr, ",") 'Turn the 1d array into a string which can be searched using Instr

For i = 7 To 10 'Use row numbers the groups are on
    iGroup = Split(ws.Range("C" & i).Value, ",") 'Split the group into an array
    iMatch = 0 'Reset the counters
    iCounter = 0
    For j = LBound(iGroup) To UBound(iGroup) 'From start of array to end
        iGroup(j) = Replace(iGroup(j), " ", "") 'remove any spaces if it does
        If iGroup(j) <> "" Then 'Checks it is not blank
            iCounter = iCounter + 1
            If InStr(SearchString, iGroup(j)) > 0 Then 'See if current item is found in search string
                iMatch = iMatch + 1
            End If
        End If
    Next j
    ws.Range("J" & i).Value = iCounter 'Send results to the sheet for the group
    ws.Range("K" & i).Value = iMatch
Next i
    
End Sub

使用For i = 7 To 10，如果您有更多的组要进入，您当然可以找到最后一行，因此这可能是一个变量。