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
相关推荐
羊小猪~~2 分钟前
数据结构C语言描述2(图文结合)--有头单链表,无头单链表(两种方法),链表反转、有序链表构建、排序等操作,考研可看
c语言·数据结构·c++·考研·算法·链表·visual studio
一名技术极客4 分钟前
Vue2 doc、excel、pdf、ppt、txt、图片以及视频等在线预览
pdf·powerpoint·excel·文件在线预览
用余生去守护23 分钟前
【反射率】-- Lab 转换(excel)
excel
进击的六角龙24 分钟前
Python中处理Excel的基本概念(如工作簿、工作表等)
开发语言·python·excel
TracyDemo25 分钟前
excel功能
excel
lc寒曦25 分钟前
【VBA实战】用Excel制作排序算法动画
排序算法·excel·vba
王哈哈^_^28 分钟前
【数据集】【YOLO】【VOC】目标检测数据集,查找数据集,yolo目标检测算法详细实战训练步骤!
人工智能·深度学习·算法·yolo·目标检测·计算机视觉·pyqt
zzzgd81628 分钟前
easyexcel实现自定义的策略类, 最后追加错误提示列, 自适应列宽,自动合并重复单元格, 美化表头
java·excel·表格·easyexcel·导入导出
努力学习技能的LY28 分钟前
Excel:vba实现批量插入图片批注
excel
星沁城30 分钟前
240. 搜索二维矩阵 II
java·线性代数·算法·leetcode·矩阵