Excel·VBA数组组合函数、组合求和

薛定谔_51

已于 2024-03-25 15:18:24 修改

阅读量9.3k

点赞数 13

分类专栏： # Excel VBA 算法文章标签： excel vba 排列组合算法

于 2022-05-04 21:23:43 首次发布

本文链接：https://blog.csdn.net/hhhhh_51/article/details/124577302

版权

Excel 同时被 3 个专栏收录

79 篇文章 71 订阅

订阅专栏

VBA

76 篇文章 25 订阅

订阅专栏

算法

8 篇文章 0 订阅

订阅专栏

《百度百科-组合》
组合、组合数：从n个不同元素中，任取m(m≤n)个元素并成一组，叫做从n个不同元素中取出m个元素的一个组合；从n个不同元素中取出m(m≤n)个元素的所有组合的个数，叫做从n个不同元素中取出m个元素的组合数

组合个数公式：C(n,m)=n!/(m!(n-m)!)

1，组合代码思路

从1-7共7个数字中选出5个数字，共21种组合，如图
在这里插入图片描述
观察每个组合的数字排列规律，可以发现每次最后一个数字排列到尾数7的时候，前面一个数字递增1，后面依次排列到尾数7；且后面的几个数字如果存在依次递增的情况时，前面的一个数字递增1，后面依次排列到尾数7，直至完成21种组合

2，VBA数组组合函数（返回二维数组）

Function combin_arr(ByVal arr, ByVal n&)
    'arr一维数组，内含m个元素，抽取n个进行组合，返回二维数组，每行为一个组合(数组从1开始计数)
    Dim i&, j&, k&, l&, m&, kk&, t&, temp
    If LBound(arr) = 0 Then  '转为从1开始计数
        arr = WorksheetFunction.Transpose(WorksheetFunction.Transpose(arr))
    End If
    If n = 1 Then combin_arr = WorksheetFunction.Transpose(arr): Exit Function
    m = UBound(arr) - LBound(arr) + 1
    kk = Application.Combin(m, n)
    ReDim brr(1 To kk, 1 To n)
    
    ReDim a&(1 To n)
    For j = 1 To n - 1
        a(j) = j
    Next
    
    i = n - 1: k = 0 ': j = n  '上面for结束后j=n；加不加j = n都一样
    Do
        For i = a(n - 1) + 1 To m  '仅修改最后一位
            a(n) = i
            k = k + 1
            For l = 1 To n
                brr(k, l) = arr(a(l))
            Next
        Next
        If a(n - 1) <> a(n) - 1 And a(n) = m Then
            a(n - 1) = a(n - 1) + 1
        ElseIf a(n - 1) = a(n) - 1 And a(n) = m Then
            For t = n - 1 To 1 Step -1  'a(j)进步，避免n=2情况报错，因而只n-1
                If a(t) <> a(t + 1) - 1 Then
                    temp = a(t) + 1: a(t) = temp: t = t + 1
                    Do Until t = n      '为真退出，先判断；最后一位不修改
                        a(t) = a(t - 1) + 1: t = t + 1
                    Loop
                    Exit For
                End If
            Next
        End If
    Loop Until k = kk
    combin_arr = brr
End Function

以上代码及思路，部分参考excelhome大神“香川群子”，原版代码如下

Function CombinArr(arr, n&)
    'arr一维数组，内含m个元素，抽取n个进行组合，返回二维数组，每行为一个组合(数组从1开始计数)
    '源代码by kagawa，https://club.excelhome.net/?218774
    Dim i&, j&, k&, l&, m&
    m = UBound(arr) - LBound(arr) + 1
    k = Application.Combin(m, n)
    ReDim brr(1 To k, 1 To n)
    
    ReDim a&(1 To n)
    For j = 1 To n - 1
        a(j) = j
    Next
    
    i = n - 1: k = 0 ': j = n
    Do
        For i = i + 1 To m
            a(j) = i
            k = k + 1
            For l = 1 To n
                brr(k, l) = arr(a(l))
            Next
        Next
        
        For j = j - 1 To 1 Step -1
            i = a(j) + 1: a(j) = i
            If i = m - n + j Then
                k = k + 1
                For l = 1 To n
                    brr(k, l) = arr(a(l))
                Next
            Else
                j = j + 1
                Do Until j = n
                    i = i + 1: a(j) = i: j = j + 1
                Loop
                If i = m Then Exit Do Else Exit For
            End If
        Next
    Loop Until j = 0
    CombinArr = brr
End Function

以上2种代码写法输出效果一致，耗时基本一致
测试在excel表格中输出1-16共16个数字的全组合形式，共65535种组合，用时都为1秒

Private Sub combin_arr测试()
    Dim arr, brr, i&, r&
    tm = Timer
    arr = Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16)
    arr = WorksheetFunction.Transpose(WorksheetFunction.Transpose(arr))  '从1开始计数一维数组
    [a1] = "全组合"
    For i = 1 To UBound(arr)
        brr = combin_arr(arr, i)
        r = Cells(1, "a").CurrentRegion.Rows.count + 1
        Cells(r, "a").Resize(UBound(brr), UBound(brr, 2)) = brr
    Next
    Debug.Print "组合用时" & Format(Timer - tm, "0.00")  '耗时
End Sub

3，组合求和（利用二维数组）

组合最常见的应用就是从一堆数字中凑金额，即组合求和
举例：从A列19个数字中选取6个数字，使其和为39085，在右侧输出结果
在这里插入图片描述

Function TransposeArr(ByVal data_arr, Optional ByVal res& = 1)
    '二维数组与一维嵌套数组互相转换函数，data_arr和返回数组从1开始计数
    Dim i&, j&, result
    If res = 1 Then  '转为一维嵌套数组
        ReDim result(1 To UBound(data_arr) - LBound(data_arr) + 1)
        For i = LBound(data_arr) To UBound(data_arr)
            temp = Application.index(data_arr, i)
            j = j + 1: result(j) = temp
        Next
        TransposeArr = result
    ElseIf res = 2 Then  '转为二维数组
        Dim rr&, cc&, r&, c&, tmp&
        rr = UBound(data_arr) - LBound(data_arr) + 1
        For Each a In data_arr
            tmp = UBound(a) - LBound(a) + 1
            If tmp > cc Then cc = tmp
        Next
        ReDim result(1 To rr, 1 To cc)
        For Each a In data_arr
            r = r + 1: c = 0
            For i = LBound(a) To UBound(a)
                c = c + 1: result(r, c) = a(i)
            Next
        Next
        TransposeArr = result
    End If
End Function

Sub 组合求和()
    Dim m&, n&, h, j&, arr, brr, crr
    tm = Timer
    m = [a1].End(xlDown).row - 1  '待组合元素个数
    n = [b4]  '组合个数
    h = [b2]  '目标和值
    arr = [a2].Resize(m): arr = WorksheetFunction.Transpose(arr)  '单列转一维数组
'--------------------原生函数返回二维数组
'    brr = combin_arr(arr, n)  '调用函数返回组合，二维数组
'    For j = 1 To UBound(brr)  '遍历数组
'        temp = Application.index(brr, j): temp_sum = WorksheetFunction.Sum(temp)
'        If temp_sum = h Then
'            r = Cells(65535, "i").End(xlUp).row + 1
'            Cells(r, "i").Resize(1, 3) = Array(n, temp_sum, Join(temp, "+"))
'        End If
'    Next
'--------------------一维嵌套数组，遍历方法1
    crr = TransposeArr(brr)  '''调用函数，将二维数组转为一维嵌套数组
'    For j = 1 To UBound(crr)
'        temp_sum = WorksheetFunction.Sum(crr(j))
'        If temp_sum = h Then
'            r = Cells(65535, "i").End(xlUp).row + 1
'            Cells(r, "i").Resize(1, 3) = Array(n, temp_sum, Join(crr(j), "+"))
'        End If
'    Next
'--------------------一维嵌套数组，遍历方法2，速度无影响
    For Each c In crr
        temp_sum = WorksheetFunction.Sum(c)
        If temp_sum = h Then
            r = Cells(65535, "i").End(xlUp).row + 1
            Cells(r, "i").Resize(1, 3) = Array(n, temp_sum, Join(c, "+"))
        End If
    Next
    Debug.Print "组合求和完成，累计用时：" & Format(Timer - tm, "0.00")  '耗时
End Sub

测试结果：共27132个组合，耗时秒数

二维数组	一维嵌套数组1	一维嵌套数组2
241	243	239

显然速度非常慢，那么数组组合函数直接生成一维嵌套数组时，组合求和速度能否提高呢？

4，VBA数组组合函数（返回一维嵌套数组）

Function combin_arr1(ByVal arr, ByVal n&)
    'arr一维数组，内含m个元素，抽取n个进行组合，返回一维嵌套数组，每行为一个组合(数组从1开始计数)
    Dim i&, j&, k&, l&, m&, kk&, t&, temp
    If LBound(arr) = 0 Then  '转为从1开始计数
        arr = WorksheetFunction.Transpose(WorksheetFunction.Transpose(arr))
    End If
    m = UBound(arr) - LBound(arr) + 1
    kk = Application.Combin(m, n): ReDim brr(1 To kk)
    If n = 1 Then
        For i = 1 To m
            brr(i) = WorksheetFunction.Transpose(WorksheetFunction.Transpose(Array(arr(i))))
        Next
        combin_arr1 = brr: Exit Function
    End If
    
    ReDim a&(1 To n), b(1 To n)
    For j = 1 To n - 1
        a(j) = j
    Next
    
    i = n - 1: k = 0 ': j = n  '上面for结束后j=n，加不加j = n都一样
    Do
        For i = a(n - 1) + 1 To m  '仅修改最后一位
            a(n) = i
            For l = 1 To n
                b(l) = arr(a(l))
            Next
            k = k + 1: brr(k) = b
        Next
        If a(n - 1) <> a(n) - 1 And a(n) = m Then
            a(n - 1) = a(n - 1) + 1
        ElseIf a(n - 1) = a(n) - 1 And a(n) = m Then
            For t = n - 1 To 1 Step -1      'a(j)进步，避免n=2情况报错，因而只n-1
                If a(t) <> a(t + 1) - 1 Then
                    temp = a(t) + 1: a(t) = temp: t = t + 1
                    Do Until t = n          '为真退出，先判断；最后一位不修改
                        a(t) = a(t - 1) + 1: t = t + 1
                    Loop
                    Exit For
                End If
            Next
        End If
    Loop Until k = kk
    combin_arr1 = brr
End Function

Sub 组合求和1()
    Dim m&, n&, h, j&, arr, brr, crr
    tm = Timer
    m = [a1].End(xlDown).row - 1  '待组合元素个数
    n = [b4]  '组合个数
    h = [b2]  '目标和值
    arr = [a2].Resize(m): arr = WorksheetFunction.Transpose(arr)  '单列转一维数组
    brr = combin_arr1(arr, n)  '调用函数返回组合，一维嵌套数组
    For Each b In brr
        temp_sum = WorksheetFunction.Sum(b)
        If temp_sum = h Then
            r = Cells(65535, "i").End(xlUp).row + 1
            Cells(r, "i").Resize(1, 3) = Array(n, temp_sum, Join(b, "+"))
        End If
    Next
    Debug.Print "组合求和完成，累计用时：" & Format(Timer - tm, "0.00")  '耗时
End Sub

测试结果：共27132个组合，耗时仅0.12秒，比二维数组快了2000倍

5，VBA组合求和（利用一维嵌套数组）

Sub 组合求和()
    Dim m&, n&, n2&, h, h2, i&, arr, brr
    tm = Timer
    '参数检查、获取
    If Len([b2]) = 0 Then Debug.Print "B2不得为空": Exit Sub
    m = [a1].End(xlDown).row - 1  '【待组合元素个数m】
    n = [b4]: n2 = [b5]: If n2 = 0 Then If n = 0 Then n = 1: n2 = m Else n2 = n  '【组合个数范围】[n,n2]
    If n = 0 Then n = 1  '情况：n=0, n2=自然数
    h = [b2]: h2 = [b3]: If Len(h2) = 0 Then h2 = h  '【目标和值范围】[h,h2]
    arr = [a2].Resize(m): arr = WorksheetFunction.Transpose(arr)  '单列转一维数组
    For i = n To n2
        brr = combin_arr1(arr, i)  '调用函数返回组合，一维嵌套数组
        For Each b In brr
            temp_sum = WorksheetFunction.Sum(b)
            'If temp_sum >= h And temp_sum <= h2 Then  'h为浮点数时，有时相等却为False，改为下行
            If Abs(Round(temp_sum - h, 6)) < (0.1 ^ 6) Or Abs(Round(temp_sum - h2, 6)) < (0.1 ^ 6) _
            Or (temp_sum >= h And temp_sum <= h2) Then
                r = Cells(65535, "i").End(xlUp).row + 1
                Cells(r, "i").Resize(1, 3) = Array(i, temp_sum, Join(b, "+"))
            End If
        Next
    Next
    Debug.Print "组合求和完成，累计用时：" & Format(Timer - tm, "0.00")  '耗时
End Sub

在这里插入图片描述
测试结果：全组合2^19-1共5242887个组合，耗时仅2.67秒

薛定谔_51

关注

13
点赞
踩
51

收藏

觉得还不错? 一键收藏
打赏
14
评论
Excel·VBA数组组合函数、组合求和

观察每个组合的数字排列规律，可以发现每次最后一个数字排列到尾数7的时候，前面一个数字递增1，后面依次排列到尾数7；且后面的几个数字如果存在依次递增的情况时，前面的一个数字递增1，后面依次排列到尾数7，直至完成21种组合。组合、组合数：从n个不同元素中，任取m(m≤n)个元素并成一组，叫做从n个不同元素中取出m个元素的一个组合；从n个不同元素中取出m(m≤n)个元素的所有组合的个数，叫做从n个不同元素中取出m个元素的组合数。从1-7共7个数字中选出5个数字，共21种组合，如图。
复制链接

扫一扫