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 時間: 2019-4-27 16:05
