返回目录：excel表格制作
这个排列组合经常要用到，托您的问题，我学习了一下，做了一个排列组合的代码。只当抛砖引玉，希望有高手批评指正。（这个程序是将10个数字，按每条4个数字进行组合）
Sub 组合()
Dim arr_S(1 To 10)
Dim arr_O
Dim I, J, K1, K2, K3, K4 As Integer
I = Sheet1.Range("A65536").End(xlUp).Row
'arr_S = Sheets("sheet1").Range("a2:a" & I) 这个运行时出错7a686964616fe58685e5aeb9366
For J = 1 To I - 1 '给原始序列数组赋值
arr_S(J) = Cells(J + 1, 1)
Next J
I = I - 1 '原始数据的个数
J = I * (I - 1) * (I - 2) * (I - 3) / (1 * 2 * 3 * 4) '按4列组合，计算目标数组的个数
ReDim arr_O(1 To J, 1 To 4)
J = 1
For K1 = 1 To I - 3
For K2 = K1 + 1 To I - 2
For K3 = K2 + 1 To I - 1
For K4 = K3 + 1 To I
arr_O(J, 1) = arr_S(K1)
arr_O(J, 2) = arr_S(K2)
arr_O(J, 3) = arr_S(K3)
arr_O(J, 4) = arr_S(K4)
J = J + 1
Next K4
Next K3
Next K2
Next K1
For I = 1 To J - 1
Cells(I + 1, 3) = arr_O(I, 1)
Cells(I + 1, 4) = arr_O(I, 2)
Cells(I + 1, 5) = arr_O(I, 3)
Cells(I + 1, 6) = arr_O(I, 4)
Next I
End Sub
执行结果如图所示：
在E1输入以百下公度式，然知后向道下填充版到E64单元权格
=CHOOSE(MOD(INT((ROW(A1)-1)/16),4)+1,1,2,3,4)&CHOOSE(MOD(INT((ROW(A1)-1)/8),4)+1,1,2,3,4)&CHOOSE(MOD(INT((ROW(A1)-1)/4),4)+1,1,2,3,4)&CHOOSE(MOD(ROW(A1)-1,4)+1,1,2,3,4)
Option Explicit
Function MyPermut(MyAr As Range)
Dim i As Integer, j As Integer, k As Double, p As Integer, q As Integer
Dim NumFree() As Boolean, TotalNum As Double, MyMtrx()
Dim MyFetch() As Integer
Dim c, arr(1 To 4)
i = 0
For Each c In MyAr
i = i + 1
arr(i) = c
If i = 4 Then Exit For
Next c
TotalNum = Application.WorksheetFunction.Permut(4, 4)
ReDim NumFree(1 To 4) '输入数字返回该数是否自由（未取）
ReDim MyMtrx(1 To TotalNum, 1 To 4)
ReDim MyFetch(1 To 4) '输入列号，返回该列应取数字
For i = 1 To 4
MyFetch(i) = i '初始化
Next i
For k = 1 To TotalNum
For i = 1 To 4 '列号
MyMtrx(k, i) = arr(MyFetch(i))
Next i
NumFree(MyFetch(4)) = True '释放最末列的数字
For j = 4 - 1 To 1 Step -1 '从倒数第2列开始往前
NumFree(MyFetch(j)) = True '释放当前列
For i = MyFetch(j) + 1 To 4 '向下试探
If NumFree(i) Then
MyFetch(j) = i
NumFree(i) = False
For p = j + 1 To 4 '从当前列往后逐列从上往下找数
For q = 1 To 4 '数字从上往下找
If NumFree(q) Then
MyFetch(p) = q
NumFree(q) = False
Exit For
End If
Next q
Next p
Exit For
End If
Next i
If Not NumFree(MyFetch(4)) Then '最末列都取到数了，跳出e799bee5baa6e4b893e5b19e366
Exit For
End If
Next j
Next k
MyPermut = MyMtrx
End Function
用公式知复杂，运行会慢一些，道用VBA简单，如果数内据太多，可用数组加快速度。见附件容
For A1 = 1 To 4
For A2 = 1 To 4
If A1 <> A2 Then
For A3 = 1 To 4
If A3 <> A2 And A3 <> A1 Then
For A4 = 1 To 4
If A4 <> A3 And A4 <> A2 And A4 <> A1 Then
n = n + 1
Cells(n, "B") = Cells(A1, 1) & Cells(A2, 1) & Cells(A3, 1) & Cells(A4, 1)
End If
Next
End If
Next
End If
Next
Next