用excel里的宏实现​ 排列组合

发布网友 发布时间：2024-08-20 22:00

我来回答

共1个回答

热心网友 时间：2024-08-20 23:02

下面是固定提取数的主要代码vba（即在C（m,n）中n是固定的） 需排列数据在arr数组中 n是组合后的结果数量 n = WorksheetFunction.Combin(h, 6) ReDim arr1(1 To n, 1 To 6) For a = 1 To h For b = 1 a To h For c = 1 b To h For d = 1 c To h For e = 1 d To h For f = 1 e To h i = i 1 arr1(i, 1) = arr(a, 1) arr1(i, 2) = arr(b, 1) arr1(i, 3) = arr(c, 1) arr1(i, 4) = arr(d, 1) arr1(i, 5) = arr(e, 1) arr1(i, 6) = arr(f, 1) Next f Next e Next d Next c Next b Next a 建议你直接运行代码理解吧（如从1~8取6，只有28个结果，相信你看到结果就能理解的），不知怎么解释 如果你需要m,n两数都是不固定的，以下是我以前写的，现在也不知道怎么解释了，还是那一句，你得自己运行并理解 Sub Cmn固定数组法() '固定数组法 Dim rng Dim r As Range Dim tc As Long, i_z As Long Dim MaxR As Long, max As Double, n1 As Long, n2 As Long, n3 As Long Dim i As Long, j As Long, c As Long Dim all(), arr(), arr_z() Dim str As String, str_arr As String On Error Resume Next Set rng = Application.InputBox("请选择一个单元格区域", "明天beyond", Type:=8) If rng Is Nothing Then Exit Sub On Error GoTo 0 '将rng中非空的值传入数组arr For Each r In rng If r <> "" Then ReDim Preserve arr(i) arr(i) = r.Value i = i 1 End If Next 'Application.ScreenUpdating = False i_z = i str = "选取元素总个数：" & i & vbLf Set rng = Nothing tc = Application.InputBox("请输入组合个数", "明天beyond", Type:=1) If tc = 0 Or tc > i Then Exit Sub '判断提取数是否大于待提取数，如果为真则退出 'MaxR 是表示在第一次取值（提取第二位）时能到达的最大数。 t = Timer MaxR = i - tc 1 max = WorksheetFunction.Combin(i, tc) ReDim all(1 To max, 1 To tc * 2) ReDim arr_z(1 To max) For i = 1 To MaxR all(i, 1) = arr(i - 1) all(i, 2) = i 1 Next ji = MaxR For c = 1 To tc - 1 n1 = 1 n2 = c * 2 1 For i = 1 To ji For j = all(i, c * 2) To MaxR c all(n1, n2) = all(i, n2 - 2) & "-" & arr(j - 1) all(n1, n2 1) = j 1 n1 = n1 1 Next Next ji = n1 - 1 Next n3 = tc * 2 - 1 For i = 1 To max arr_z(i) = all(i, n3) Next '___________________ 'Application.ScreenUpdating = True t = Timer - t t2 = Timer On Error Resume Next Set rng = Application.InputBox("结果保存到……？", "明天beyond", Type:=8) If rng Is Nothing Then Exit Sub On Error GoTo 0 tc = WorksheetFunction.Combin(i_z, tc) str = str & "结果有" & tc & "个" If tc > Rows.Count Then MsgBox "无法保存全部结果，只能保存前" & Rows.Count & "条" rng.Range("a1").Resize(tc, 1) = WorksheetFunction.Transpose(arr_z) MsgBox "已完成操作!" & vbLf & vbLf & str & "时间" & Timer - t2 t, vbInformation, "明天beyond" End Sub