返回列表 上一主題 發帖

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

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

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

求助.zip (6.36 KB)

有人幫忙嗎?

TOP

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

TOP

回復 3# ikboy

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

TOP

回復 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

TOP

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

TOP

        靜思自在 : 【時間成就一切】時間可以造就人格,可以成就事業,也可以儲積功德。
返回列表 上一主題