Vba Excel宏，用于查找相关产品（具有类似功能）并将其分配给产品

我制作了一张工作表的屏幕截图，以便更容易解释/理解：

因此，正如您在图纸的每一行上看到的，1有一个产品名称（红色）及其功能（右侧）。可能有数百种产品，每种产品都有随机数量的功能。许多产品（行）有一个或几个匹配的功能，但有些可能没有

我需要一些自动化的方法来为每个产品分配另外5个与该产品最相似的产品（按相似性定位）。产品具有的匹配功能越多，与给定产品的相似性就越高。所以，一个匹配了5个的产品会作为第一个相对匹配的产品，一个匹配了4个相对匹配的产品，等等，但是可能没有匹配。然后，它应该得到一个随机的产品作为一个相对分配

这是一张Sheet2的屏幕截图，我想象处理后的结果在视觉上应该是什么样子（但它与逻辑不匹配，因为我没有手动选择正确的亲属）：

我已经制作了一个Excel表格示例，但我现在只是在脑海中创建了它，它可能不是一个完美的表格，下面是：

---

Excel宏有可能做到这一点吗？如果是，怎么做？

下面的代码涵盖了您需要的所有内容，但如果没有找到匹配项，则随机条目除外，在这种情况下，它将只返回最后一行，其中0个匹配项。我建议将它放在

工作表的
工作表2
上激活（）

，否则重命名它并将其设置为按钮或您需要的任何内容

Sub Worksheet_Activate()

' Determine the max number of rows from Sheet1
Dim maxRows As Integer
maxRows = Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row

' Determine how many matches each row gets with the other rows
Dim matches()
ReDim matches(1 To maxRows, 1 To maxRows) ' Create the match hits as an array
For i = 1 To maxRows ' Loop over each row
    For j = 1 To maxRows ' Loop over each row again
        matches(i, j) = 0 ' Set all matches in the array to zero
        For k = 1 To Sheets("Sheet1").Cells(i, 1).End(xlToRight).Column ' Loop over columns for row i
            For l = 1 To Sheets("Sheet1").Cells(j, 1).End(xlToRight).Column ' Loop over columns for row j
                If Sheets("Sheet1").Cells(i, k).Value = Sheets("Sheet1").Cells(j, l).Value Then ' If a match occurs
                    matches(i, j) = matches(i, j) + 1 ' Increase the counter by 1
                End If
            Next
        Next
    Next
    matches(i, i) = 0 ' Set self row matches to 0, else would get the row itself is highest match
Next

' Determine the top five matches
Dim maxValue, maxIndex As Integer
maxValue = 0
maxIndex = 0
For i = 1 To maxRows ' Loop over each row
    For j = 1 To 5 ' Required 5 matches
        For k = 1 To maxRows ' Loop over each row again
            If matches(i, k) > maxValue Then ' If to find the highest maxValue
                maxValue = matches(i, k) ' Set the maxValue
                maxIndex = k ' Set the index of the maxValue
             End If
        Next
        Sheets("Sheet2").Cells(i, j + 1).Value = Sheets("Sheet1").Cells(maxIndex, 1).Value ' Set the appropriate cell to highest hit
        matches(i, maxIndex) = 0 ' Set the index to 0 to avoid duplication in next loop iteration
        maxValue = 0 ' Reset for next loop
        maxIndex = 0 ' Reset for next loop
    Next
Next

End Sub

---

如果您需要任何进一步的更改，请告诉我。还包括每行的演练。

如果您可以发布实际的预期结果，这将有所帮助。这样我们就可以测试VBA是否可行。我的第一个猜测是肯定的。非常感谢，据我所知，它工作正常。唯一能让它变得更好的是，如果它能处理得更快，因为我感到震惊的是，有1000行和50列，它可能无法完成。。。