找全异的三组数据（附件已正常）

天地一相

感谢帮助！详见截图附件。附件下载已正常，请再次看看吧。
我的思路：
  1：按循环逐个组装成一个数据行，每组装一个字典一个。例如示例是每组5个，则组装后是一个15个单元格的数据行，然后字典，无相同的则判断为是，提取出来。然后下一个，直至循环结束，找出全部符合全异的组合。
2：三组数据全配对一次性装入数组（包括序号），然后对组装的每一组新数据查重（序号除外），最后写回找到的结果

天地一相

请管理员看看，发现我的帖子包括历史贴，下载附件全部字节为0了，昨天上午发现这种情况的。谢谢。thank you

MaterSeCret

附件有问题估计是你的电脑有加密软件之类的，然后也看不懂你这个是想表达什么意思

hhlty

'设数据是从A1单元格开始，无标题

Sub test()
    Dim arr, brr, crr, drr
    Dim i, j, k, m, n, npoint, nMax, nMaxCol, col
    Dim p
   
    nMax = Cells(Rows.Count, 1).End(xlUp).Row
    nMaxCol = Cells(1, Columns.Count).End(xlToLeft).Column
    col = (nMaxCol + 1) / 3 - 1
   
    ReDim drr(1 To 3 * col - 3)
    arr = Range(Cells(1, 1), Cells(nMax, col))
    brr = Range(Cells(1, col + 2), Cells(nMax, 2 * col + 2))
    crr = Range(Cells(1, 2 * col + 3), Cells(nMax, 3 * col + 3))
   
    npoint = 1
    For i = LBound(arr) To UBound(arr)
        For j = LBound(brr) To UBound(brr)
            For k = LBound(crr) To UBound(crr)
                p = 0
                For m = 1 To col - 1
                    drr(m) = arr(i, 1 + m)
                    drr(col - 1 + m) = brr(j, 1 + m)
                    drr(2 * col - 2 + m) = crr(k, 1 + m)
                Next m
               
                For m = 1 To 3 * col - 4
                    For n = m + 1 To 3 * col - 3
                        If drr(m) = drr(n) Then
                            p = 1
                            Exit For
                        End If
                    Next n
                    If p Then Exit For
                Next m
               
                If p = 0 Then
                    For m = 1 To col
                        Cells(nMax + npoint, m) = arr(i, m)
                        Cells(nMax + npoint, col + 1 + m) = brr(j, m)
                        Cells(nMax + npoint, 2 * col + 2 + m) = crr(k, m)
                    Next m
                    npoint = npoint + 1
                End If
               
            Next k
        Next j
    Next i
               
        
End Sub

天地一相

hhlty 发表于 2023-12-14 15:22
'设数据是从A1单元格开始，无标题

Sub test()

感谢，改用循环与公式解决了。