|
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件 ★ 免费下载 ★ ★ 使用帮助★
Option Explicit
Sub test()
Dim ar, br, cr, i&, j&, dic As Object, strJoin$
Set dic = CreateObject("Scripting.Dictionary")
br = [A1].Resize(5).Value
ReDim ar(1 To UBound(br))
For i = 1 To UBound(br)
ReDim cr(1 To Len(br(i, 1)), 1 To 1)
For j = 1 To UBound(cr)
cr(j, 1) = Mid(br(i, 1), j, 1)
Next j
ar(i) = cr
Next i
ar = cartesianProduct1(ar)
For i = 1 To UBound(ar)
If i = 1 Then strJoin = Join(ar(i), "") Else strJoin = strJoin & vbCrLf & Join(ar(i), "")
qSort1 ar(i), 1, UBound(ar(i))
dic(Join(ar(i), "")) = Empty
Next i
[A7].Value = strJoin
br = dic.keys
qSort1 br, 0, UBound(br)
[A8].Value = Join(br, vbCrLf)
Beep
End Sub
Function qSort1(ByRef ar, ByVal iFirst&, ByVal iLast&, _
Optional ByVal isOrder As Boolean = True)
Dim i&, j&, k&, vTemp1, vTemp2
i = iFirst: j = iLast: vTemp1 = ar((iFirst + iLast) / 2)
While i <= j
If isOrder Then
While ar(i) < vTemp1: i = i + 1: Wend
While vTemp1 < ar(j): j = j - 1: Wend
Else
While ar(i) > vTemp1: i = i + 1: Wend
While vTemp1 > ar(j): j = j - 1: Wend
End If
If i <= j Then
vTemp2 = ar(i): ar(i) = ar(j): ar(j) = vTemp2
i = i + 1: j = j - 1
End If
Wend
If iFirst < j Then qSort1 ar, iFirst, j, isOrder
If i < iLast Then qSort1 ar, i, iLast, isOrder
End Function
Function cartesianProduct1(ByVal ar) As Variant
Dim br&(), cr, vResult(), iGroup&, i&, j&, m&, n&, x&
n = UBound(ar)
For i = 1 To UBound(ar)
m = m + UBound(ar(i), 2)
Next i
ReDim br(1 To n)
ReDim cr(1 To m)
For j = 1 To n: br(j) = 1: Next
iGroup = 0
Do
x = 0
For j = 1 To n
For i = 1 To UBound(ar(j), 2)
x = x + 1
cr(x) = ar(j)(br(j), i)
Next i
Next
iGroup = iGroup + 1
ReDim Preserve vResult(1 To iGroup)
vResult(iGroup) = cr
For j = n To 1 Step -1
br(j) = br(j) + 1
If br(j) <= UBound(ar(j)) Then Exit For Else br(j) = 1
Next
Loop Until j = 0
cartesianProduct1 = vResult
End Function
|
评分
-
2
查看全部评分
-
|