VBA Dictionary全排列组合

@VBA

Dictionary全排列组合

如何插入一段漂亮的代码片

代码片.

Sub test()
    Set t1 = CreateObject("Scripting.Dictionary")         ''ԭʼ×ÖµäÊý¾Ý
    t1.Add 1, "A": t1.Add 2, "B": t1.Add 3, "C": t1.Add 4, "D"
    
    Set rt = CreateObject("Scripting.Dictionary")        ''È«ÅÅÁнá¹û
    
    Call compareAll(t1, t1.Count, rt)
    k = rt.keys: v = rt.items
    For i = 0 To rt.Count - 1
        Debug.Print k(i) & "     " & v(i)
        
    Next i
End Sub

Function compareAll(ByVal t1 As Object, ByVal zhs As Integer, ByVal rt As Object)
    k1 = t1.keys: v1 = t1.items: tCount = t1.Count
    For k = 1 To 2 ^ zhs - 1
        bitValue = getBitValue(zhs, k): rtString = ""
        For i = UBound(bitValue) To 1 Step -1
            a = bitValue(i)
            If a = 1 Then rtString = rtString + CStr(v1(i - 1))
        Next i
        rt.Add Join(bitValue, ""), rtString
    Next k
End Function


Function getBitValue(ByVal zhs As Integer, ByVal k As Integer)
    ReDim arr(1 To zhs)
    For i = 1 To zhs
        arr(zhs - i + 1) = 1 * Abs(GetBit(k, i))
    Next i
    ''getBitValue = Join(arr, "")
    getBitValue = arr
End Function

Function GetBit(ByVal i As Double, ByVal n As Double) As Boolean
    GetBit = i And 2 ^ (n - 1)
End Function

输出结果.

0001     D
0010     C
0011     DC
0100     B
0101     DB
0110     CB
0111     DCB
1000     A
1001     DA
1010     CA
1011     DCA
1100     BA
1101     DBA
1110     CBA
1111     DCBA