a1~a39, 填入1~39,然後耐心等= =
Sub test()
Dim n As Variant, c As Double
n = Application.Transpose(Range("A1", Range("A1").End(xlDown)))
Application.ScreenUpdating = False
For i = 1 To UBound(n)
For j = i + 1 To UBound(n)
For k = j + 1 To UBound(n)
For l = k + 1 To UBound(n)
For m = l + 1 To UBound(n)
c = c + 1
Cells(c, 2) = n(i)
Cells(c, 3) = n(j)
Cells(c, 4) = n(k)
Cells(c, 5) = n(l)
Cells(c, 6) = n(m)
Next m
Next l
Next k
Next j
Next i
Application.ScreenUpdating = True
MsgBox c & "組"
End Sub
Sub test()
Const n = 39
ReDim T(n) As String
Dim C1%, C2%, C3%, C4%, C5%
Dim Arr(), Brr()
T0 = Timer
For i = 1 To n: T(i) = Format(i, "00"): Next
For C1 = 1 To n: For C2 = C1 + 1 To n: For C3 = C2 + 1 To n
For C4 = C3 + 1 To n: For C5 = C4 + 1 To n
k = k + 1: ReDim Preserve Arr(1 To 1, 1 To k)
Arr(1, k) = T(C1) & " " & T(C2) & " " & T(C3) & " " & T(C4) & " " & T(C5)
Next: Next: Next: Next: Next
'[A1].Resize(UBound(Arr, 2), 1) = Application.Transpose(Arr) '陣列太大會產生錯誤......
'攔-列交換(自己手動寫)
ReDim Brr(1 To UBound(Arr, 2), 1 To 1)
For i = 1 To UBound(Arr, 2): Brr(i, 1) = Arr(1, i): Next
[A1].Resize(UBound(Brr)) = Brr: Columns.AutoFit
MsgBox "已列出" & UBound(Brr) & "組，" & "共使用時間" & Round(Timer - T0, 2) & "秒"
Erase Arr: Erase Brr
End Sub
謝謝教學,用你教的方法
改寫前跑3分鐘,改寫後6秒左右跑完 ^^
Sub test2()
Dim m As Integer, n As Integer, c As Double, t(1 To 39) As Integer, r As Double, arr()
For i = 1 To 39: t(i) = i: Next i
m = 39
n = 5
t0 = Timer
c = Cmn(m) / (Cmn(m - n) * Cmn(n))
ReDim arr(1 To c, 1 To n)
Application.ScreenUpdating = False
For i = 1 To m
For j = i + 1 To m
For k = j + 1 To m
For l = k + 1 To m
For p = l + 1 To m
r = r + 1
arr(r, 1) = t(i)
arr(r, 2) = t(j)
arr(r, 3) = t(k)
arr(r, 4) = t(l)
arr(r, 5) = t(p)
Next p
Next l
Next k
Next j
Next i
Range(Cells(1, 1), Cells(r, 5)) = arr()
Application.ScreenUpdating = True
MsgBox r & "組：使用時間" & Timer - t0 & "秒"
End Sub
Function Cmn(x As Integer) As Double
Dim i As Integer, y As Double
y = 1
For i = 1 To x
y = y * i
Next
Cmn = y
End Function
發表於 2020-2-14 16:57
| 
