麻辣家族討論版版 - Powered by Discuz! Board

Option Explicit
Sub Ex() '數字的重排
Dim w As String, i As Single, t As Single
Dim ww As String, Ar(), Arr(), At(), tt As Single
w = 66654422 '指定數字
t = Application.WorksheetFunction.Fact(Len(w)) 'Fact(工作表函數):數字的階乘。某數的階乘等於 1*2*3*...* 數字
'*******************************************
t = t / 3 '666重複
t = t / 2 '44重複
t = t / 2 '22重複
t = t / 3 '2,4,6重複
'*******************************************
ReDim At(1 To t) ' '設立重新排列的總數的陣列
ReDim Ar(1 To Len(w))
For i = 1 To Len(w)
Ar(i) = Mid(w, i, 1) '數字指定到陣列中
Next
'**********************************
For i = 1 To UBound(At)
ww = "" '清空
Do
Randomize '初始化亂數產生器
Arr = Ar 'Ar(數字指定的陣列)置入 Arr
Do
tt = Int(((Len(w)) * Rnd) + 1) '亂數
If Arr(tt) <> "" Then
ww = ww & Arr(tt)
Arr(tt) = "" '清空
End If
Loop Until Len(Join(Arr, "")) = 0 'Arr 全部清空
If InStr("," & Join(At, ",") & ",", "," & ww & ",") Then '數字存在"重新排列的總數的陣列
ww = ""
Else
At(i) = ww
Exit Do
End If
Loop
Next
[a1].Resize(t) = Application.WorksheetFunction.Transpose(At)
End Sub

複製代碼