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

vbnet 复制代码
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

vbnet 复制代码
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举例

vbnet 复制代码
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时,计算所有分组形式
vbnet 复制代码
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

举例

vbnet 复制代码
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

mode参数为1,last_row参数为0,求和模式、输出所有分组形式(以下为部分截图)

mode参数为2,last_row参数为0,字符串模式、输出所有分组形式(以下为部分截图)

测试结果 9个元素分成4组 10个元素分成4组
总分组数 18480 88110
耗时秒数 6.34 26.57
相关推荐
YuTaoShao20 分钟前
【LeetCode 热题 100】994. 腐烂的橘子——BFS
java·linux·算法·leetcode·宽度优先
Wendy14418 小时前
【线性回归(最小二乘法MSE)】——机器学习
算法·机器学习·线性回归
拾光拾趣录8 小时前
括号生成算法
前端·算法
渣呵9 小时前
求不重叠区间总和最大值
算法
拾光拾趣录9 小时前
链表合并:双指针与递归
前端·javascript·算法
好易学·数据结构9 小时前
可视化图解算法56:岛屿数量
数据结构·算法·leetcode·力扣·回溯·牛客网
香蕉可乐荷包蛋10 小时前
AI算法之图像识别与分类
人工智能·学习·算法
chuxinweihui11 小时前
stack,queue,priority_queue的模拟实现及常用接口
算法
tomato0911 小时前
河南萌新联赛2025第(一)场:河南工业大学(补题)
c++·算法
墨染点香11 小时前
LeetCode Hot100【5. 最长回文子串】
算法·leetcode·职场和发展