Excel·VBA数组分组问题

看到一个帖子《excel吧-数据分组问题》，对一组数据分成4组，使每组的和值相近
在这里插入图片描述

代码思路

在这里插入图片描述

n个元素分成m组，每组元素个数最小值为1，最大值为n-m+1，可以通过组合获取所有分组形式
所有元素进行分组，即组合问题，4组组合数相乘就是一种分组形式的分组数（注意：因为组合不区分顺序，因此当分组内组合的指数为1时，不管底数是多少，分组数都为1）。通过观察上图，可以发现9种元素分成4组，有6种分组形式共18480种分组
有了分组形式和分组数，那就可以获取每种分组形式中的每个分组元素组成
函数调用：以下代码调用了《Excel·VBA数组冒泡排序函数》bubble_sort函数，《Excel·VBA数组组合函数、组合求和》combin_arr1函数（如需使用代码需复制）

1，分组形式、可分组数

有2种代码及结果输出形式，主要使用第2种

代码1

Function 可分组数(ByVal n&, ByVal m&, Optional ByVal mode& = 1)
    '计算分组成不重复的组数，可选择最终返回组数，和每格内含元素个数的二维数组（从1开始计数）
    'n元素个数；m需要分成几组；mode为1时返回组数，为2时返回二维数组（组数行*m列）
    Dim arr, brr, crr, drr, x&, y&, i&, j&, t, tt, a, b, d, s, bb, k, krr, res
    ReDim arr(1 To n - m + 1), brr(1 To n - m + 1)  '组合法计算组数，最大值为n - m + 1
    x = n - m + 1: arr(1) = 1: brr(1) = m - 1  'arr元素个数，brr重复次数
    If m = 1 Then
        If mode = 1 Then
            可分组数 = 1: Exit Function
        ElseIf mode = 2 Then
            ReDim res(1 To 1, 1 To 1): res(1, 1) = n: 可分组数 = res: Exit Function
        End If
    End If
    For i = 2 To x  '每个数字各最多需要的数量
        arr(i) = i: t = n \ i: tt = n / i  '整除、除，判断是否相等
        If t = tt And t = m Then  '整除，且正好分配为m组
            brr(i) = t
        Else
            For j = t To 1 Step -1
                a = i * j + (m - j)  '数字i有j个，其余为1，判断和是否<=n
                If a <= n Then brr(i) = j: Exit For
            Next
        End If
    Next
    s = WorksheetFunction.Sum(brr): ReDim crr(1 To s)
    For i = x To 1 Step -1  '倒序、正序平均分组都在最后
        For j = 1 To brr(i)
            y = y + 1: crr(y) = arr(i)  '所有数字按个数写入一个数组
        Next
    Next
    '对数组crr选m个进行组合，获取和值为n，且组合形式唯一的所有组合
    Dim dict As Object: Set dict = CreateObject("scripting.dictionary"): x = 0
    drr = combin_arr1(crr, m)  '调用函数返回组合，一维嵌套数组
    For Each d In drr  '遍历组合，和值等于n；再降序排序，写入字典
        s = WorksheetFunction.Sum(d)
        If s = n Then b = bubble_sort(d, "-"): bb = Join(b, "+"): dict(bb) = ""
    Next
    '对符合条件的组合形式，计算分成m组的组数，以及每种组合形式的组数
    For Each k In dict.keys
        krr = Split(k, "+"): s = n: y = 1
        For i = 0 To m - 1   '分组中只有1个元素的无所谓顺序，排除
            If krr(i) > 1 Then y = y * Application.Combin(s, krr(i)): s = s - krr(i)
        Next
        dict(k) = y: x = x + y    'y每种组合形式的组数，x总组数
    Next
    If mode = 1 Then    '输出结果
        可分组数 = x
    ElseIf mode = 2 Then
        ReDim res(1 To x, 1 To m): i = 0
        For Each k In dict.keys
            krr = Split(k, "+")
            For y = 1 To dict(k)  '重复写入dict(k)行krr数组
                i = i + 1
                For j = 0 To m - 1
                    res(i, j + 1) = krr(j)
                Next
            Next
        Next
        可分组数 = res
    End If
End Function

代码2

Function 可分组数2(ByVal n&, ByVal m&, Optional ByVal mode& = 1)
    '计算分组成不重复的组数，可选择最终返回总组数，或每种组合形式的组数的二维数组（从1开始计数）
    'n元素个数；m需要分成几组；mode为1时返回组数，为2时返回二维数组，1列组合形式1列组数
    Dim arr, brr, crr, drr, x&, y&, i&, j&, t, tt, a, b, d, s, bb, k, res
    ReDim arr(1 To n - m + 1), brr(1 To n - m + 1)  '组合法计算组数，最大值为n - m + 1
    x = n - m + 1: arr(1) = 1: brr(1) = m - 1  'arr元素个数，brr重复次数
    If m = 1 Or n = m Then
        If mode = 1 Then
            可分组数2 = 1
        ElseIf mode = 2 Then
            ReDim res(1 To 1, 1 To 2): res(1, 2) = 1
            res(1, 1) = WorksheetFunction.Rept("1", m): 可分组数2 = res
        End If
        Exit Function
    End If
    For i = 2 To x  '每个数字各最多需要的数量
        arr(i) = i: t = n \ i: tt = n / i  '整除、除，判断是否相等
        If t = tt And t = m Then  '整除，且正好分配为m组
            brr(i) = t
        Else
            For j = t To 1 Step -1
                a = i * j + (m - j)  '数字i有j个，其余为1，判断和是否<=n
                If a <= n Then brr(i) = j: Exit For
            Next
        End If
    Next
    s = WorksheetFunction.Sum(brr): ReDim crr(1 To s)
    For i = x To 1 Step -1  '倒序、正序平均分组都在最后
        For j = 1 To brr(i)
            y = y + 1: crr(y) = arr(i)  '所有数字按个数写入一个数组
        Next
    Next
    '对数组crr选m个进行组合，获取和值为n，且组合形式唯一的所有组合
    Dim dict As Object: Set dict = CreateObject("scripting.dictionary"): x = 0
    drr = combin_arr1(crr, m)  '调用函数返回组合，一维嵌套数组
    For Each d In drr  '遍历组合，和值等于n；再降序排序，写入字典
        s = WorksheetFunction.Sum(d)
        If s = n Then b = bubble_sort(d, "-"): bb = Join(b, "+"): dict(bb) = ""
    Next
    '对符合条件的组合形式，计算分成m组的组数，以及每种组合形式的组数
    For Each k In dict.keys
        krr = Split(k, "+"): s = n: y = 1
        For i = 0 To m - 1   '分组中只有1个元素的无所谓顺序，排除
            If krr(i) > 1 Then y = y * Application.Combin(s, krr(i)): s = s - krr(i)
        Next
        dict(k) = y: x = x + y    'y每种组合形式的组数，x总组数
    Next
    If mode = 1 Then    '输出结果
        可分组数2 = x
    ElseIf mode = 2 Then
        ReDim res(1 To dict.Count, 1 To 2): i = 0
        For Each k In dict.keys
            i = i + 1: res(i, 1) = k: res(i, 2) = dict(k)
        Next
        可分组数2 = res
    End If
End Function

代码2举例

Sub 可分组数2举例()
    arr = 可分组数2(9, 4, 2)
    If IsArray(arr) Then
        [a1].Resize(UBound(arr), UBound(arr, 2)) = arr
    Else
        Debug.Print arr
    End If
End Sub

在这里插入图片描述
生成的分组形式和分组数都和手工计算一致
代码1的输出结果是上图A列每行按"+"号拆分成4列及重复对应B列数字行数，最终生成结果为18480行*4列

2，数组所有分组形式

为方便后续计算方差，返回结果有分组和值和分组字符串2种形式。可以先调用函数获取和值计算方差及对应的行号，再调用函数获取字符串组成形式，输出行号对应的结果
为减少计算量，last_row参数可以控制是计算所有分组形式，还是仅计算后x行分组形式。因为brr数组越后面元素分布越均匀，当需要计算方差的数组数值之间差异较小时，last_row较小则可以更快计算出结果；而如果数值差异较大的，可以适当增大last_row以便计算正确的结果；last_row等于0时，计算所有分组形式

Function 数组分组(ByVal data_arr, ByVal m&, Optional ByVal mode& = 1, Optional ByVal last_row& = 1)
    '对数组data_arr分为m组，结果返回二维数组（n行*m列），每列为和值/组成元素（数组从1开始计数）
    'data_arr元素数组；m需要分成几组；mode为1时返回和值，为2时返回字符串
    '为减少计算量，因为brr数组越后面元素分布越均匀，故last_row参数仅对brr数组的后last_row行进行分组
    Dim arr, brr, br, srr, sr, a, n&, i&, j&, x&, y&, r&, rr&, c&, t&, w&, res, trr, temp, s&
    ReDim arr(1 To 1000)
    If mode <> 1 And mode <> 2 Then Debug.Print "参数错误": Exit Function
    For Each a In data_arr  '多行多列的，按列从左往右读取，排除空值
        If Len(a) Then i = i + 1: arr(i) = a
    Next
    n = i: ReDim Preserve arr(1 To n): brr = 可分组数2(n, m, 2)
    If last_row > 0 And last_row < UBound(brr) Then  'last_row为2即仅计算brr数组后2行；为0则全部计算
        ReDim br(1 To last_row, 1 To 2)
        For i = 1 To last_row
            br(i, 1) = brr(i + UBound(brr) - last_row, 1): br(i, 2) = brr(i + UBound(brr) - last_row, 2)
        Next
        brr = br
    End If
    x = WorksheetFunction.Sum(Application.Index(brr, , 2))
    ReDim srr(1 To UBound(brr), 1 To m), sr(1 To UBound(brr), 1 To m)
    For i = 1 To UBound(brr)   'brr第1列转为数组
        temp = Split(brr(i, 1), "+"): t = brr(i, 2): s = n
        For j = 1 To m
            srr(i, j) = temp(j - 1)
        Next
        For j = 1 To m         '计算重复次数
            If srr(i, j) > 1 Then
                t = t \ Application.Combin(s, srr(i, j)): sr(i, j) = t: s = s - srr(i, j)
            Else
                sr(i, j) = 1
            End If
        Next
    Next
    i = 1: r = 0: c = 1: rr = 0: ReDim res(1 To x, 1 To m)
    Do
        Do While c = 1  '第1列赋值
            crr = combin_arr1(arr, srr(i, c)): t = sr(i, c)  '重复写入t次
            For Each a In crr
                For j = 1 To t
                    r = r + 1: res(r, c) = a
                Next
            Next
            If i < UBound(brr) Then i = i + 1 Else Exit Do
        Loop
        i = 1: r = 1: rr = 0: c = 2: ReDim temp(1 To n)  '除第1列的其他列，按列赋值
        Do
            ts = "": y = 0     'trr数组记录剩余元素，temp临时数组
            For j = 1 To c - 1
                ts = ts & "++" & Join(res(r, j), "++") & "++"
            Next
            For Each a In arr  '排除前一列已使用元素，且前后+号避免部分重复元素被找到
                aa = "+" & CStr(a) & "+"
                If InStr(ts, aa) = 0 Then
                    y = y + 1: temp(y) = a
                Else
                    ts = Replace(ts, aa, "", , 1)
                End If
            Next
            ReDim trr(1 To y)
            For j = 1 To y     'trr数组更新元素，且转换格式，否则导致求和错误
                trr(j) = CDbl(temp(j))
            Next
            If c <> m Then
                crr = combin_arr1(trr, srr(i, c)): w = 可分组数2(y, m - c + 1)
                If w = 1 Then  '只赋值第1个，避免c递增后出错
                    res(r, c) = crr(1): rr = rr + 1
                Else
                    t = sr(i, c): r = r - 1
                    For Each a In crr
                        For j = 1 To t
                            r = r + 1: res(r, c) = a: rr = rr + 1
                        Next
                    Next
                End If
            Else
                res(r, c) = trr: rr = rr + 1  '最后一列直接赋值，只有1组
            End If
            r = r + 1  '下一行
            If rr >= brr(i, 2) Then rr = 0: i = i + 1  'brr一行循环结束，进入下一轮
            If i > UBound(brr) Then i = 1: r = 1: c = c + 1
        Loop Until c > m
    Loop Until r = 1  '所有写入完成后，r=1
    If mode = 1 Then  '返回结果，求和模式
        For i = 1 To x
            For j = 1 To m
                res(i, j) = WorksheetFunction.Sum(res(i, j))
            Next
        Next
    Else              '字符串模式
        For i = 1 To x
            For j = 1 To m
                res(i, j) = Join(res(i, j), "+")
            Next
        Next
    End If
    数组分组 = res
End Function

举例

Sub 数组分组举例()
    tm = Timer
    arr = Array(1, 2, 3, 4, 5, 6, 7, 8, 9): a = 数组分组(arr, 4, 1, 0)
    [a1].Resize(UBound(a), UBound(a, 2)) = a
    Debug.Print "累计用时" & Format(Timer - tm, "0.00")  '耗时
End Sub