Excel宏可以查找产品并将相关产品（具有类似功能）分配给产品

Question

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

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

我需要一些自动方式为每个产品分配另外5个与该产品最相似的产品（按相似性定位）。产品具有的匹配功能越多，它们与给定产品的相似性就越高。因此，具有5个匹配的产品作为第一个相对的产品，具有4秒的产品等，但是可能没有匹配。然后它应该得到一个被指定为亲戚的随机产品。

这是Sheet2的截图，我怎么想象处理后的结果看起来应该是直观的（但它与逻辑不匹配，因为我没有手动选择正确的亲属）：

我已经制作了一个示例Excel表格，但我现在只是想出来并且它可能不是最好的一个，这里是：https://dl.dropboxusercontent.com/u/69246594/related.xlsm

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

Answer 1

下面的代码涵盖了你需要的一切，除非找不到匹配的随机条目，在这种情况下它只会返回它与0匹配的最后一行。我建议将Sheet2放在Worksheet_Activate()上，否则将其重命名并将其设置为按钮或任何您需要的内容。

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

您可能需要的任何进一步更改让我知道。其中还包括每行的演练。