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

標題: 動態陣列 (排列組合) [打印本頁]

作者: Andy2483 時間: 2021-9-27 13:42 標題: 動態陣列 (排列組合)

各位前輩好
請教動態陣列
1.下列程式碼的陣列數是5個
2.任意個陣列數都能列出其排列組合要如何設計?
謝謝指導

Option Explicit
Sub TEST_20210927()
Dim i&, C&, Arr, Brr, x&
Arr = Array(1, 10, 100, 1000, 10000)
ReDim Brr(0 To 100, 1)
C = 0
For i = 0 To UBound(Arr)
Brr(C, 0) = Arr(i)
Brr(C, 1) = "單一"
C = C + 1
Next
For i = 0 To UBound(Arr)
For x = i + 1 To UBound(Arr)
   Brr(C, 0) = Arr(i) + Arr(x)
   Brr(C, 1) = "2個相加"
   C = C + 1
Next
Next
For i = 0 To UBound(Arr) - 1
For x = i + 1 To UBound(Arr) - 1
   Brr(C, 0) = Arr(i) + Arr(x) + Arr(x + 1)
   Brr(C, 1) = "3個相加"
   C = C + 1
Next
Next
For i = 0 To UBound(Arr) - 3
For x = i + 1 To UBound(Arr) - 2
   Brr(C, 0) = Arr(i) + Arr(x) + Arr(x + 1) + Arr(x + 2)
   Brr(C, 1) = "4個相加"
   C = C + 1
Next
Next
For i = 0 To UBound(Arr) - 4
For x = i + 1 To UBound(Arr) - 3
   Brr(C, 0) = Arr(i) + Arr(x) + Arr(x + 1) + Arr(x + 2) + Arr(x + 3)
   Brr(C, 1) = "5個相加"
   C = C + 1
Next
Next
[A1].Resize(UBound(Arr) + 1, 1) = Application.Transpose(Arr)
[B1].Resize(UBound(Brr), 2) = Brr
End Sub

作者: Andy2483 時間: 2021-9-27 14:07

補充說明
陣列裡的值不一定是10的倍數,是任意的正整數
這範例只是自己方便判斷用的
不好意思!沒交代清楚!
謝謝指導!

作者: Andy2483 時間: 2021-9-28 12:01

回復 1# Andy2483

少了幾個組合

Option Explicit
Sub TEST_20210928() '
Dim i&, C&, Arr, Brr, x&
Arr = Array(1, 10, 100, 1000, 10000)
ReDim Brr(0 To 1000, 1)
C = 0
For i = 0 To UBound(Arr)
Brr(C, 0) = Arr(i)
Brr(C, 1) = "單一"
C = C + 1
Next
For i = 0 To UBound(Arr)
For x = i + 1 To UBound(Arr)
   Brr(C, 0) = Arr(i) + Arr(x)
   Brr(C, 1) = "2個相加"
   C = C + 1
Next
Next
For i = 0 To UBound(Arr) - 1
For x = i + 1 To UBound(Arr) - 1
   Brr(C, 0) = Arr(i) + Arr(x) + Arr(x + 1)
   Brr(C, 1) = "3個相加"
   C = C + 1
Next
For x = i + 1 To UBound(Arr) - 2
   Brr(C, 0) = Arr(i) + Arr(x) + Arr(x + 2)
   Brr(C, 1) = "3個相加"
   C = C + 1
Next
For x = i + 1 To UBound(Arr) - 3
   Brr(C, 0) = Arr(i) + Arr(x) + Arr(x + 3)
   Brr(C, 1) = "3個相加"
   C = C + 1
Next
Next
For i = 0 To UBound(Arr) - 3
For x = i + 1 To UBound(Arr) - 2
   Brr(C, 0) = Arr(i) + Arr(x) + Arr(x + 1) + Arr(x + 2)
   Brr(C, 1) = "4個相加"
   C = C + 1
Next
For x = i + 1 To UBound(Arr) - 3
   Brr(C, 0) = Arr(i) + Arr(x) + Arr(x + 2) + Arr(x + 3)
   Brr(C, 1) = "4個相加"
   C = C + 1
Next
For x = i + 1 To UBound(Arr) - 3
   Brr(C, 0) = Arr(i) + Arr(x) + Arr(x + 1) + Arr(x + 3)
   Brr(C, 1) = "4個相加"
   C = C + 1
Next
For x = i + 2 To UBound(Arr) - 3
   Brr(C, 0) = Arr(i) + Arr(x + 1) + Arr(x + 2) + Arr(x + 3)
   Brr(C, 1) = "4個相加"
   C = C + 1
Next
Next
For i = 0 To UBound(Arr) - 4
For x = i + 1 To UBound(Arr) - 3
   Brr(C, 0) = Arr(i) + Arr(x) + Arr(x + 1) + Arr(x + 2) + Arr(x + 3)
   Brr(C, 1) = "5個相加"
   C = C + 1
Next
Next
Workbooks.Add
[A1].Resize(UBound(Arr) + 1, 1) = Application.Transpose(Arr)
[B1].Resize(UBound(Brr), 2) = Brr
End Sub

作者: Andy2483 時間: 2021-9-28 16:07

陣列數 2  個> 排列組合 3 個
陣列數 3  個> 排列組合 7 個
陣列數 4  個> 排列組合 15 個
陣列數 5  個> 排列組合 31 個
陣列數 6  個> 排列組合 63 個

歸納起來是 2 的 N次方個 (N是陣列數)
下列程式碼可排列出陣列數 6  個> 排列組合 63 個
請教各位前輩有辦法簡化並加到陣列數 100  個嗎?
謝謝指導!

Option Explicit
Sub TEST_20210928_1()
Dim i&, C&, Arr, Brr, x&
Arr = Array(1, 10, 100, 1000, 10000, 100000)
ReDim Brr(0 To 1000, 1)
C = 0
On Error Resume Next
For i = 0 To UBound(Arr)
Brr(C, 0) = Arr(i)
Brr(C, 1) = "單一"
C = C + 1
Next
For i = 0 To UBound(Arr)
For x = i To UBound(Arr)
   If i <> x Then
      Brr(C, 0) = Arr(i) + Arr(x)
      Brr(C, 1) = "2個相加"
      C = C + 1
   End If
Next
Next
For i = 0 To UBound(Arr)
For x = i To UBound(Arr)
   If i <> x Then
      Brr(C, 0) = Arr(i) + Arr(x) + Arr(x + 1)
      Brr(C, 1) = "3個相加"
      C = C + 1
   End If
Next
For x = i To UBound(Arr)
   If i <> x Then
      Brr(C, 0) = Arr(i) + Arr(x) + Arr(x + 2)
      Brr(C, 1) = "3個相加"
      C = C + 1
   End If
Next
For x = i To UBound(Arr)
   If i <> x Then
      Brr(C, 0) = Arr(i) + Arr(x) + Arr(x + 3)
      Brr(C, 1) = "3個相加"
      C = C + 1
   End If
Next
For x = i To UBound(Arr)
   If i <> x Then
      Brr(C, 0) = Arr(i) + Arr(x) + Arr(x + 4)
      Brr(C, 1) = "3個相加"
      C = C + 1
   End If
Next
For x = i To UBound(Arr)
   If i <> x Then
      Brr(C, 0) = Arr(i) + Arr(x + 1) + Arr(x + 2)
      Brr(C, 1) = "3個相加"
      C = C + 1
   End If
Next
For x = i To UBound(Arr)
   If i <> x Then
      Brr(C, 0) = Arr(i) + Arr(x + 1) + Arr(x + 3)
      Brr(C, 1) = "3個相加"
      C = C + 1
   End If
Next
For x = i To UBound(Arr)
   If i <> x Then
      Brr(C, 0) = Arr(i) + Arr(x + 1) + Arr(x + 4)
      Brr(C, 1) = "3個相加"
      C = C + 1
   End If
Next
For x = i To UBound(Arr)
   If i <> x Then
      Brr(C, 0) = Arr(i) + Arr(x + 2) + Arr(x + 3)
      Brr(C, 1) = "3個相加"
      C = C + 1
   End If
Next
For x = i To UBound(Arr)
   If i <> x Then
      Brr(C, 0) = Arr(i) + Arr(x + 2) + Arr(x + 4)
      Brr(C, 1) = "3個相加"
      C = C + 1
   End If
Next
For x = i To UBound(Arr)
   If i <> x Then
      Brr(C, 0) = Arr(i) + Arr(x + 3) + Arr(x + 4)
      Brr(C, 1) = "3個相加"
      C = C + 1
   End If
Next
Next
For i = 0 To UBound(Arr)
For x = i To UBound(Arr)
   If i <> x Then
      Brr(C, 0) = Arr(i) + Arr(x) + Arr(x + 1) + Arr(x + 2)
      Brr(C, 1) = "4個相加"
      C = C + 1
   End If
Next
For x = i To UBound(Arr)
   If i <> x Then
      Brr(C, 0) = Arr(i) + Arr(x) + Arr(x + 1) + Arr(x + 3)
      Brr(C, 1) = "4個相加"
      C = C + 1
   End If
Next
For x = i To UBound(Arr)
   If i <> x Then
      Brr(C, 0) = Arr(i) + Arr(x) + Arr(x + 1) + Arr(x + 4)
      Brr(C, 1) = "4個相加"
      C = C + 1
   End If
Next
For x = i To UBound(Arr)
   If i <> x Then
      Brr(C, 0) = Arr(i) + Arr(x) + Arr(x + 2) + Arr(x + 3)
      Brr(C, 1) = "4個相加"
      C = C + 1
   End If
Next
For x = i To UBound(Arr)
   If i <> x Then
      Brr(C, 0) = Arr(i) + Arr(x) + Arr(x + 2) + Arr(x + 4)
      Brr(C, 1) = "4個相加"
      C = C + 1
   End If
Next
For x = i To UBound(Arr)
   If i <> x Then
      Brr(C, 0) = Arr(i) + Arr(x) + Arr(x + 3) + Arr(x + 4)
      Brr(C, 1) = "4個相加"
      C = C + 1
   End If
Next
For x = i To UBound(Arr)
   If i <> x Then
      Brr(C, 0) = Arr(i) + Arr(x + 1) + Arr(x + 2) + Arr(x + 3)
      Brr(C, 1) = "4個相加"
      C = C + 1
   End If
Next
For x = i To UBound(Arr)
   If i <> x Then
      Brr(C, 0) = Arr(i) + Arr(x + 1) + Arr(x + 2) + Arr(x + 4)
      Brr(C, 1) = "4個相加"
      C = C + 1
   End If
Next
For x = i To UBound(Arr)
   If i <> x Then
      Brr(C, 0) = Arr(i) + Arr(x + 1) + Arr(x + 3) + Arr(x + 4)
      Brr(C, 1) = "4個相加"
      C = C + 1
   End If
Next
For x = i To UBound(Arr)
   If i <> x Then
      Brr(C, 0) = Arr(i) + Arr(x + 2) + Arr(x + 3) + Arr(x + 4)
      Brr(C, 1) = "4個相加"
      C = C + 1
   End If
Next
Next

For i = 0 To UBound(Arr)
For x = i To UBound(Arr)
   If i <> x Then
      Brr(C, 0) = Arr(i) + Arr(x) + Arr(x + 1) + Arr(x + 2) + Arr(x + 3)
      Brr(C, 1) = "5個相加"
      C = C + 1
   End If
Next
For x = i To UBound(Arr)
   If i <> x Then
      Brr(C, 0) = Arr(i) + Arr(x) + Arr(x + 2) + Arr(x + 3) + Arr(x + 4)
      Brr(C, 1) = "5個相加"
      C = C + 1
   End If
Next
For x = i To UBound(Arr)
   If i <> x Then
      Brr(C, 0) = Arr(i) + Arr(x) + Arr(x + 1) + Arr(x + 3) + Arr(x + 4)
      Brr(C, 1) = "5個相加"
      C = C + 1
   End If
Next
For x = i To UBound(Arr)
   If i <> x Then
      Brr(C, 0) = Arr(i) + Arr(x) + Arr(x + 1) + Arr(x + 2) + Arr(x + 4)
      Brr(C, 1) = "5個相加"
      C = C + 1
   End If
Next
For x = i To UBound(Arr)
   If i <> x Then
      Brr(C, 0) = Arr(i) + Arr(x + 1) + Arr(x + 2) + Arr(x + 3) + Arr(x + 4)
      Brr(C, 1) = "5個相加"
      C = C + 1
   End If
Next
For x = i To UBound(Arr)
   If i <> x Then
      Brr(C, 0) = Arr(i) + Arr(x + 1) + Arr(x + 2) + Arr(x + 3) + Arr(x + 4)
      Brr(C, 1) = "5個相加"
      C = C + 1
   End If
Next
For x = i To UBound(Arr)
   If i <> x Then
      Brr(C, 0) = Arr(i) + Arr(x + 1) + Arr(x + 2) + Arr(x + 3) + Arr(x + 4)
      Brr(C, 1) = "5個相加"
      C = C + 1
   End If
Next
For x = i To UBound(Arr)
   If i <> x Then
      Brr(C, 0) = Arr(i) + Arr(x + 1) + Arr(x + 2) + Arr(x + 3) + Arr(x + 4)
      Brr(C, 1) = "5個相加"
      C = C + 1
   End If
Next
Next
Brr(C, 0) = Arr(0) + Arr(1) + Arr(2) + Arr(3) + Arr(4) + Arr(5)
Brr(C, 1) = "6個相加"
Workbooks.Add
[A1].Resize(UBound(Arr) + 1, 1) = Application.Transpose(Arr)
[B1].Resize(UBound(Brr), 2) = Brr
[B:B].AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Columns _
      ("E:E"), Unique:=True
[E:E].Sort _
KEY1:=[E1], Order1:=xlAscending, _
Header:=xlGuess, OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom, SortMethod:=xlStroke, _
DataOption1:=xlSortNormal
End Sub

作者: Andy2483 時間: 2021-9-29 11:28

找到方法了! 謝謝各位前輩.stillfish00,PKKO
參考帖子: http://forum.twbts.com/viewthread.php?tid=18001

Option Explicit
Sub ListCombination_Add()
Dim Arr, n&, i&, j&, Brr
Arr = Array(1, 10, 100, 1000, 10000, 100000, 1000000, 10000000, 100000000, 1000000000, 10000000000#)
n = UBound(Arr) - LBound(Arr) + 1
ReDim Brr(1 To 2 ^ n - 1, 1 To n + 1)
For i = 1 To 2 ^ n - 1
For j = 0 To n - 1
   If i And 2 ^ j Then
      Brr(i, j + 1) = Arr(j)
      Brr(i, n + 1) = Brr(i, n + 1) + Arr(j)
   End If
Next
Next
Workbooks.Add
Cells.ClearContents
[A1].Resize(UBound(Brr), UBound(Brr, 2)) = Brr
Cells.Columns.AutoFit
End Sub

歡迎光臨麻辣家族討論版版 (http://forum.twbts.com/)