[發問] 求vba如何將 [A1]拆開窮舉不重複組合

ikboy

求vba如何將 [A1]拆開窮舉不重複組合
即 AB , BA 將視為重複 , 衹取 AB

ikboy

有人幫忙嗎?

ikboy

已解決了, 另效果欠了第6行ABD

zheng211016

回復 3# ikboy

這數學問題好難哈哈 求樓主分享

ikboy

回復 4# zheng211016


    Sub zz()
    Dim s$, a(), m&, k&, i&
    [c1].CurrentRegion.Offset(1, 0).ClearContents
    s = [a1].Value
    m = Len(s)
    ReDim a(1 To m)
    For i = 1 To m
        a(i) = Mid(s, i, 1)
    Next i
    ReDim b(1 To 2 ^ m - 1, 1 To 3)
    k = 0: Call recursive(a, m, k, "", 1, b)
    [c2].Resize(UBound(b), UBound(b, 2)) = b
    [c2].Resize(UBound(b), UBound(b, 2)).Sort key1:=[e2], key2:=[d2], key3:=[c2]
    [c2].CurrentRegion.Offset(0, 1).Resize(, 2).Clear
End Sub
Sub recursive(a, m, k, s$, n&, b)
    Dim i&, j&, ss$, c(), t&
    For j = 0 To 1
        If j Then ss = a(n) Else ss = ""
        If n < m Then
            Call recursive(a, m, k, IIf(ss = "", s, ss & s), n + 1, b)
        Else
            If Len(ss & s) Then
                k = k + 1: b(k, 1) = IIf(ss = "", s, ss & s)
                ReDim c(1 To Len(b(k, 1)))
                t = 0
                For i = UBound(c) To 1 Step -1
                    t = t + 1
                    c(i) = Mid(b(k, 1), t, 1)
                Next
                b(k, 1) = Join(c, "")
                b(k, 2) = Len(b(k, 1))
                b(k, 3) = Left(b(k, 1), 1)
            End If
        End If
    Next j
End Sub

Farnsworth

感谢分享，试用你的代码，谢谢，支持你的努力。