求助，如何用VBA在EXCEL表格寻找相同的值？

阿智

一共有22列，108行。
在每行里抽取3个单元格进行组合，然后跟下面每一行相应的单元格值做比较，找出30行都相同的组合在W列中将该组合输出在后面的空白格里。·
举例：假如A1,B1,C1,跟下面这29行
A2,B2,C2,
A3,B3,C3,
A4,B4,C4,
A5,B5,C5,
A6,B6,C6,
A7,B7,C7,
A8,B8,C8,
A9,B9,C9,
A10,B10,C10,
A11,B11,C11,
A12,B12,C12,
A13,B13,C13,
A14,B14,C14,
A15,B15,C15,
A16,B16,C16,
A17,B17,C17,
A18,B18,C18,
A19,B19,C19,
A20,B20,C20,
A21,B21,C21,
A22,B22,C22,
A23,B23,C23,
A24,B24,C24,
A25,B25,C25,
A26,B26,C26,
A27,B27,C27,
A28,B28,C28,
A29,B29,C29,
A30,B30,C30,
A31,B31,C31,
相对应的单元格值都相同，那么就在W列中将这30行组合输出来。

liulang0808

楼主看下是不是这个意思吧

liulang0808

楼主原来附件的数据没有满足要去的，对部分数据调整后的结果，看看是不是这样的

microyip

1. Sub 分析()
   
2.     Dim nFindCol As Integer, vData As Variant, nRow As Integer, nCol As Integer
   
3.     Dim vKey As Variant, vCol As Variant, oDic As Object
   
4.    
   
5.     nFindCol = 3 '匹配列数
   
6.     vData = [A1].CurrentRegion.Resize(, nFindCol).Value
   
7.     Set oDic = CreateObject("Scripting.Dictionary")
   
8.     ReDim vFill(1 To UBound(vData), 1 To 1)
   
9.     For nRow = 1 To UBound(vData)
   
10.         vKey = Join(FastSort(Application.WorksheetFunction.Index(vData, nRow)), "|")
    
11.         If Not oDic.Exists(vKey) Then Set oDic(vKey) = CreateObject("Scripting.Dictionary")
    
12.         ReDim vCol(1 To nFindCol)
    
13.         For nCol = 1 To nFindCol
    
14.             vCol(nCol) = Chr(64 + nCol) & nRow
    
15.         Next
    
16.         vCol = Join(vCol, "-")
    
17.         oDic(vKey)(vCol) = "'" & Join(Application.WorksheetFunction.Index(vData, nRow), "-")
    
18.     Next
    
19.     ReDim vData(1 To 2, 1 To 1)
    
20.     nRow = 0
    
21.     For Each vKey In oDic.Keys
    
22.         If oDic(vKey).Count > 1 Then
    
23.             If nRow > 0 Then nRow = nRow + 1
    
24.             For Each vCol In oDic(vKey).Keys
    
25.                 nRow = nRow + 1
    
26.                 ReDim Preserve vData(1 To 2, 1 To nRow)
    
27.                 vData(1, nRow) = vCol
    
28.                 vData(2, nRow) = oDic(vKey)(vCol)
    
29.             Next
    
30.         End If
    
31.     Next
    
32.     If nRow > 0 Then [W1:X1].Resize(nRow) = Application.WorksheetFunction.Transpose(vData)
    
33. End Sub
    
34. 
    
35. Function FastSort(ByVal vData As Variant) As Variant
    
36.     Dim nI As Double, nJ As Double, vTmp As Variant
    
37.    
    
38.     nJ = LBound(vData)
    
39.     For nI = LBound(vData) To UBound(vData) - 1
    
40.         If vData(nI) <= vData(nI + 1) Then
    
41.             If nI > nJ Then
    
42.                 nJ = nI
    
43.             Else
    
44.                 nI = nJ
    
45.             End If
    
46.         Else
    
47.             vTmp = vData(nI)
    
48.             vData(nI) = vData(nI + 1)
    
49.             vData(nI + 1) = vTmp
    
50.             If nI <> LBound(vData) Then nI = nI - 2
    
51.         End If
    
52.     Next nI
    
53.     FastSort = vData
    
54. End Function

复制代码

microyip

附上附件以供参考

阿智

liulang0808 发表于 2019-10-5 09:18
楼主原来附件的数据没有满足要去的，对部分数据调整后的结果，看看是不是这样的

谢谢你的回复,帮我解决了这个难题.

阿智

liulang0808 发表于 2019-10-5 09:18
楼主原来附件的数据没有满足要去的，对部分数据调整后的结果，看看是不是这样的

你好,发现点小问题.当把A1改为A4时,按理应该是从该行的下一行开始查找相同单元格.如果不限行数,有多少就输出多少可以嘛? 还有就是从A1到V1的组合中应该有1540种组合(从22个单元格中每次抽取3个进行组合)

liulang0808

阿智 发表于 2019-10-5 22:45
你好,发现点小问题.当把A1改为A4时,按理应该是从该行的下一行开始查找相同单元格.如果不限行数,有多少就 ...

arr = [a1].Resize(108, 22) 是对应的区域的，楼主可以根据实际情况调整的。
关于有多少个组合，应该是算满足需求的组合吧，楼主实际有这么多组满足需求的组合吗？

阿智

liulang0808 发表于 2019-10-6 07:41
arr = [a1].Resize(108, 22) 是对应的区域的，楼主可以根据实际情况调整的。
关于有多少个组合，应该是 ...

谢谢你的回复.