Excelmacros查找和分配相关产品（具有类似function）到产品

我做了一张表格的截图，以便于解释/理解：

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

我需要一些自动化的方法来为每个产品分配另外5种与产品最相似的产品（按相似性定位）。 产品匹配的特征越多，它们就越相似于给定的产品。 所以有5场比赛的产品是第一个相对的产品，4秒的产品等，但可能是没有比赛。 那么它应该得到一个随机产品作为亲属分配。

下面是一个Sheet2的截图，我怎么想像处理后的结果应该看起来像可视化（但它不符合逻辑，因为我没有手动select正确的亲属）：

我已经做了一个Excel工作表的例子，但是现在我只是把它build立起来了，可能不是一个完美的工具，在这里是： https ： //dl.dropboxusercontent.com/u/69246594/related。 XLSM

Excelmacros可以做到这一点吗？ 如果是的话，怎么样？

Answer 1

下面的代码涵盖了除了随机条目之外的所有需求，如果没有find匹配的话，那么它将只返回它匹配的最后一行。 我build议把这个在Sheet2上的Worksheet_Activate()否则重命名它，并将其设置为一个button或任何你需要的。

 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 

任何进一步的变化，你可能需要让我知道。 包括也是每行的演练。