在拉丁方里找满足条件的单元格

xihaihandsp

taller 发表于 2024-5-7 09:43

你上面代码输出的结果还是 5个单元格的值相同，  我想实现的是5个单元格的值完全不相同

xihaihandsp

xihaihandsp 发表于 2024-5-7 15:04
如果上面的改法是对的，应该也出结果，E3、F4、G5、D6、C7这5个单元格也满足条件，但是不出结果

老师你的组合的代码逻辑我读不懂了  

xihaihandsp

taller 发表于 2024-5-7 09:29
哪个组合是重复的？我测试代码没有问题

找出5个单元格的值， 值也不能重复

ooluckydog

xihaihandsp 发表于 2024-5-7 15:04
如果上面的改法是对的，应该也出结果，E3、F4、G5、D6、C7这5个单元格也满足条件，但是不出结果

嗯，是的，程序不是通用的
现在前提是在第一行里先选定一个才可以

xihaihandsp

ooluckydog 发表于 2024-5-7 15:31
嗯，是的，程序不是通用的
现在前提是在第一行里先选定一个才可以

好  谢谢老师，我好好研究一下，看能不能弄成通用的。

gwjkkkkk

Option Explicit
Sub test()
    Dim ar, br, cr, vResult(), i&, j&, n&, Rng As Range
    Dim dic As Object, isFlag As Boolean, iPosCol&
   
    Application.ScreenUpdating = False
    ReDim ar(1 To 5)
    For i = 1 To 5
        ar(i) = i
    Next i
    ar = ArrPermut(ar, 5)
   
    Set dic = CreateObject("Scripting.Dictionary")
    Columns("X:XDF").Clear
   
    Set Rng = [C3:G7]
    br = Rng.Value
    With Rng
        For i = 1 To UBound(ar)
            dic.RemoveAll: isFlag = True
            For j = 1 To UBound(ar, 2)
                If Not dic.exists(br(j, ar(i, j))) Then
                    dic(br(j, ar(i, j))) = Array(.Cells(j, ar(i, j)).Address(0, 0), j, ar(i, j))
                Else
                    isFlag = False: Exit For
                End If
            Next j
            If isFlag Then
                 n = n + 1
                 iPosCol = (n - 1) * 6 + 1 + 23
                 Rng.Copy Cells(19, iPosCol)
                 With Cells(19, iPosCol)
                     ReDim Preserve vResult(1 To 5, 1 To n)
                     For j = 0 To dic.Count - 1
                          cr = dic.items()(j)
                          vResult(j + 1, n) = cr(0)
                         .Cells(cr(1), cr(2)).Interior.Color = vbGreen
                     Next j
                 End With
            End If
        Next i
    End With
   
    If n Then [X1].Resize(5, n) = vResult
    Application.ScreenUpdating = True
    Beep
End Sub

Function ArrPermut(ar, n&)
    Dim br&(), cr&(), vResult, i&, j&, k&, m&, iGroup&
   
    m = UBound(ar)
    iGroup = WorksheetFunction.Permut(m, n)
    ReDim br&(1 To n), cr&(1 To m), vResult(1 To iGroup, 1 To n)
   
    For j = 1 To n
        br(j) = j: cr(j) = 1
        vResult(1, j) = ar(j)
    Next
    For i = 2 To iGroup
        For j = n To 1 Step -1
            cr(br(j)) = 0
            For k = br(j) + 1 To m
                If cr(k) = 0 Then Exit For
            Next
            If k <= m Then cr(k) = 1: br(j) = k: Exit For
        Next
        For j = j + 1 To n
            For k = 1 To m
                If cr(k) = 0 Then Exit For
            Next
            cr(k) = 1: br(j) = k
        Next
        For j = 1 To n
            vResult(i, j) = ar(br(j))
        Next
    Next
   
    ArrPermut = vResult
End Function

gwjkkkkk

xihaihandsp 发表于 2024-5-7 15:19
找出5个单元格的值， 值也不能重复

请参考附件。。。

xihaihandsp

gwjkkkkk 发表于 2024-5-7 21:22
请参考附件。。。

感谢老师，谢谢您帮助！！！！！！！！！！！  

xihaihandsp

gwjkkkkk 发表于 2024-5-7 21:21
Option Explicit
Sub test()
    Dim ar, br, cr, vResult(), i&, j&, n&, Rng As Range

老师，太感谢您了！！！

xihaihandsp

gwjkkkkk 发表于 2024-5-7 21:22
请参考附件。。。

老师还问一个问题，普通人要写出这样的代码，至少需要多长时间的编程学习，