Excel·VBA定量装箱、凑数值金额、组合求和问题

在这里插入图片描述
如图：对图中A-C列数据，根据C列数量按照一定的取值范围，组成一个分组装箱，要求如下：
1，每箱数量最好凑足50，否则为47-56之间；
2，图中每行数据不得拆分；
3，按顺序对分组装箱结果进行编号，如D列中BS0001；
4，生成分组装箱结果（包含B-C列数据），以及单独生成最终无法装箱的数据

目录

    • 实现方法1
    • 实现方法2
    • 实现方法3
      • 3种实现方法生成结果、对比、耗时
    • 装箱结果整理
      • 编号无序
      • 编号有序

本问题本质上是组合求和问题，调用了combin_arr1函数，代码详见《Excel·VBA数组组合函数、组合求和》（如需使用代码需复制）

实现方法1

代码思路：持续不断组合
1，对数据读取为字典，行号为键数量为值；
2，对行号数组从2-N依次进行组合，判断是否符合取值范围；
3，对符合取值范围的行号组合，在res数组对应行号中写入装箱编号，并在字典中删除该行号
4，删除行号后，跳出后续循环遍历，并重复步骤2-3，直至无法删除行号，即没有符合范围的行号组合
5，在D列写入对应的装箱编号
注意：由于步骤4需要跳出循环，所以无法使用for…each遍历组合数组，否则报错该数组被固定或暂时锁定

Sub 装箱问题1()
    Dim arr, dict As Object, i&, j&, temp_sum, res, w&, dc&, brr, r&, c&
    target = 50: trr = Array(47, 56)  '目标值，范围
    Set dict = CreateObject("scripting.dictionary"): tm = Timer
    With Worksheets("数据")  '读取数据
        arr = .[a1].CurrentRegion: ReDim res(1 To UBound(arr)): res(1) = "箱号"
        For i = 2 To UBound(arr)
            If arr(i, 3) = target Then
                w = w + 1: res(i) = "BS" & Format(w, "000")
            Else
                dict(i) = arr(i, 3)
            End If
        Next
        dc = dict.Count
        Do    '2层do方便有符合目标值时跳出，并继续组合
            Do
                For j = 2 To dc
                    brr = combin_arr1(dict.keys, j)
                    For r = 1 To UBound(brr)
                        temp_sum = 0
                        For c = 1 To UBound(brr(r))
                            temp_sum = temp_sum + dict(brr(r)(c))
                        Next
                        If temp_sum >= trr(0) And temp_sum <= trr(1) Then
                            w = w + 1
                            For c = 1 To UBound(brr(r))
                                res(brr(r)(c)) = "BS" & Format(w, "000"): dict.Remove brr(r)(c)  '写入箱号，删除行号
                            Next
                            Exit Do
                        End If
                    Next
                Next
                If dc = dict.Count Then Exit Do  '无组合符合目标值，跳出
            Loop Until dc = 0
            If dc = dict.Count Then Exit Do
            dc = dict.Count
        Loop Until dc = 0
        .[d1].Resize(UBound(res), 1) = WorksheetFunction.Transpose(res)
    End With
    Debug.Print "组合完成，累计用时" & Format(Timer - tm, "0.00")  '耗时
End Sub

实现方法2

代码思路：遍历组合，跳过重复行号
与实现方法2类似，但步骤4不同，在字典删除行号后，继续遍历组合，并判断每个组合中是否存在被删除的行号，如果存在则跳过本组合，直至无法删除行号，或剩余行号无法支持下一轮递增元素个数进行组合

Sub 装箱问题2()
    Dim arr, dict As Object, i&, j&, temp_sum, res, w&, dc&, brr, r&, c&
    target = 50: trr = Array(47, 56)  '目标值，范围
    Set dict = CreateObject("scripting.dictionary"): tm = Timer
    With Worksheets("数据")  '读取数据
        arr = .[a1].CurrentRegion: ReDim res(1 To UBound(arr)): res(1) = "箱号"
        For i = 2 To UBound(arr)
            If arr(i, 3) = target Then
                w = w + 1: res(i) = "BS" & Format(w, "000")
            Else
                dict(i) = arr(i, 3)
            End If
        Next
        For j = 2 To dict.Count
            If j > dict.Count Then Exit For  '所剩元素不足，结束
            brr = combin_arr1(dict.keys, j)
            For Each b In brr
                temp_sum = 0
                For Each bb In b
                    If Not dict.Exists(bb) Then
                        temp_sum = 0: Exit For  '重复跳过
                    Else
                        temp_sum = temp_sum + dict(bb)
                    End If
                Next
                If temp_sum >= trr(0) And temp_sum <= trr(1) Then
                    w = w + 1
                    For Each bb In b
                        res(bb) = "BS" & Format(w, "000"): dict.Remove bb  '写入箱号，删除行号
                    Next
                End If
            Next
        Next
        .[d1].Resize(UBound(res), 1) = WorksheetFunction.Transpose(res)
    End With
    Debug.Print "组合完成，累计用时" & Format(Timer - tm, "0.00")  '耗时
End Sub

实现方法3

实现方法1和实现方法2，都没有满足要求中“每箱数量最好凑足50”，仅对每行数量优先判断是否等于50，对于后续组合中都是符合范围即可
因此，对实现方法2添加1个for循环，第1遍组合满足target，第2遍组合满足目标值trr范围

Sub 装箱问题3()
    Dim arr, dict As Object, i&, j&, temp_sum, res, w&, dc&, brr, r&, c&
    target = 50: trr = Array(47, 56)  '目标值，范围
    Set dict = CreateObject("scripting.dictionary"): tm = Timer
    With Worksheets("数据")  '读取数据
        arr = .[a1].CurrentRegion: ReDim res(1 To UBound(arr)): res(1) = "箱号"
        For i = 2 To UBound(arr)
            If arr(i, 3) = target Then
                w = w + 1: res(i) = "BS" & Format(w, "000")
            Else
                dict(i) = arr(i, 3)
            End If
        Next
        For n = 1 To 2  '第1遍组合满足target，第2遍组合满足目标值trr范围
            For j = 2 To dict.Count
                If j > dict.Count Then Exit For  '所剩元素不足，结束
                brr = combin_arr1(dict.keys, j)
                For Each b In brr
                    temp_sum = 0
                    For Each bb In b
                        If Not dict.Exists(bb) Then
                            temp_sum = 0: Exit For  '重复跳过
                        Else
                            temp_sum = temp_sum + dict(bb)
                        End If
                    Next
                    If n = 1 And temp_sum = target Then
                        w = w + 1
                        For Each bb In b
                            res(bb) = "BS" & Format(w, "000"): dict.Remove bb  '写入箱号，删除行号
                        Next
                    ElseIf n = 2 And temp_sum >= trr(0) And temp_sum <= trr(1) Then
                        w = w + 1
                        For Each bb In b
                            res(bb) = "BS" & Format(w, "000"): dict.Remove bb  '写入箱号，删除行号
                        Next
                    End If
                Next
            Next
        Next
        .[d1].Resize(UBound(res), 1) = WorksheetFunction.Transpose(res)
    End With
    Debug.Print "组合完成，累计用时" & Format(Timer - tm, "0.00")  '耗时
End Sub

3种实现方法生成结果、对比、耗时

图中C列中的数量为1-50范围内的随机数，D列即为结果
分别对3种方法生成结果进行统计、对比：
方法1、2生成结果完全相同，数量分布不集中；方法3最终装箱的箱数也更少，且数量集中在50，但剩余行数多
400行数据测试，方法1、2剩余4行，方法3剩余15行
在这里插入图片描述
3种方法代码运行速度，分别测试300行、400行数据的耗时秒数
方法3对比方法2需要多生成、遍历一遍组合，由于组合数成指数递增，因此其400行相比300行耗时大幅增加，且电脑内存最高占用6G。如果要使用方法3且数据量较大，最好还是分段运行代码，避免耗时过久
在这里插入图片描述

装箱结果整理

编号无序

字典以箱号为键，值为数组

Sub 装箱结果输出1无序()
    Dim arr, dict As Object, i&, j&, r&, c&, max_c&, rng As Range, xh, dw, sl
    Set dict = CreateObject("scripting.dictionary"): tm = Timer
    With Worksheets("数据")  '读取数据
        arr = .[a1].CurrentRegion: ReDim res(1 To UBound(arr) * 2, 1 To 10)
        res(1, 1) = "箱号": r = 0: Set rng = .Cells(1, 1).Resize(1, 3)  '表头
        For i = 2 To UBound(arr)
            If Len(arr(i, 4)) Then
                xh = arr(i, 4): dw = arr(i, 2): sl = arr(i, 3)
                If Not dict.Exists(xh) Then
                    r = r + 2: dict(xh) = Array(r, 2, sl)  '箱号对应的行列号，数量合计
                    res(dict(xh)(0), 1) = xh    '箱号、单位号、数量赋值
                    res(dict(xh)(0), dict(xh)(1)) = dw
                    res(dict(xh)(0) + 1, dict(xh)(1)) = sl
                Else
                    c = dict(xh)(1) + 1: hj = dict(xh)(2) + sl  '数量合计
                    dict(xh) = Array(dict(xh)(0), c, hj)
                    res(dict(xh)(0), dict(xh)(1)) = dw  '单位号、数量赋值
                    res(dict(xh)(0) + 1, dict(xh)(1)) = sl
                    max_c = WorksheetFunction.Max(max_c, c)  '最大列数
                End If
            Else
                Set rng = Union(rng, .Cells(i, 1).Resize(1, 3))
            End If
        Next
    End With
    With Worksheets("结果")  '写入结果
        r = r + 1: max_c = max_c + 1: res(1, max_c) = "总件数"
        For i = 2 To r
            If Len(res(i, 1)) = 0 Then
                res(i, 1) = "数量": res(i, max_c) = dict(res(i - 1, 1))(2)
            End If
        Next
        For j = 2 To max_c - 1
            res(1, j) = "单位号" & (j - 1)
        Next
        .[a1].Resize(r, max_c) = res
        If Not rng Is Nothing Then rng.Copy .Cells(1, max_c + 2)  '无法装箱
    End With
    Debug.Print "累计用时" & Format(Timer - tm, "0.00")  '耗时
End Sub

生成结果：对方法2生成数据（即本文图1）进行整理
在这里插入图片描述

编号有序

字典嵌套字典，代码速度较无序版稍慢
为保证编号有序，以下代码使用了一维数组排序，调用了bubble_sort函数，代码详见《Excel·VBA数组冒泡排序函数》（如需使用代码需复制）

Sub 装箱结果输出2有序()
    Dim arr, dict As Object, i&, j&, r&, c&, max_c&, rng As Range, xh, dw, sl
    Set dict = CreateObject("scripting.dictionary"): tm = Timer
    With Worksheets("数据")  '读取数据
        arr = .[a1].CurrentRegion: ReDim res(1 To UBound(arr) * 2, 1 To 10)
        res(1, 1) = "箱号": r = 0: Set rng = .Cells(1, 1).Resize(1, 3)  '表头
        For i = 2 To UBound(arr)
            If Len(arr(i, 4)) Then
                xh = arr(i, 4): dw = arr(i, 2): sl = arr(i, 3)
                If Not dict.Exists(xh) Then
                    Set dict(xh) = CreateObject("scripting.dictionary")
                End If
                dict(xh)(dw) = dict(xh)(dw) + sl
            Else
                Set rng = Union(rng, .Cells(i, 1).Resize(1, 3))
            End If
        Next
        krr = bubble_sort(dict.keys)  '有序箱号
        For Each k In krr
            r = r + 2: c = 1: res(r, c) = k
            For Each kk In dict(k).keys
                c = c + 1: res(r, c) = kk: res(r + 1, c) = dict(k)(kk)
            Next
            max_c = WorksheetFunction.Max(max_c, c)  '最大列数
        Next
    End With
    With Worksheets("结果")  '写入结果
        r = r + 1: max_c = max_c + 1: res(1, max_c) = "总件数"
        For i = 2 To r
            If Len(res(i, 1)) = 0 Then
                res(i, 1) = "数量"
                res(i, max_c) = WorksheetFunction.sum(dict(res(i - 1, 1)).items)
            End If
        Next
        For j = 2 To max_c - 1
            res(1, j) = "单位号" & (j - 1)
        Next
        .[a1].Resize(r, max_c) = res
        If Not rng Is Nothing Then rng.Copy .Cells(1, max_c + 2)  '无法装箱
    End With
    Debug.Print "累计用时" & Format(Timer - tm, "0.00")  '耗时
End Sub

生成结果：对方法2生成数据（即本文图1）进行整理
在这里插入图片描述
附件：《Excel·VBA定量装箱、凑数值金额、组合求和问题（附件）》

扩展阅读：《excelhome-一个装箱难题》

本文来自互联网用户投稿，该文观点仅代表作者本人，不代表本站立场。本站仅提供信息存储空间服务，不拥有所有权，不承担相关法律责任。如若转载，请注明出处：/a/57625.html

如若内容造成侵权/违法违规/事实不符，请联系我们进行投诉反馈qq邮箱809451989@qq.com，一经查实，立即删除！

相关文章

webpack基础知识一：说说你对webpack的理解？解决了什么问题？

webpack基础知识一：说说你对webpack的理解？解决了什么问题？

一、背景 Webpack 最初的目标是实现前端项目的模块化&#xff0c;旨在更高效地管理和维护项目中的每一个资源 模块化 最早的时候&#xff0c;我们会通过文件划分的形式实现模块化&#xff0c;也就是将每个功能及其相关状态数据各自单独放到不同的JS 文件中 约定每个文件是一…
阅读更多...
Matlab对TMS320F28335编程-新建工程闪烁led灯

Matlab对TMS320F28335编程-新建工程闪烁led灯

前言 工具&#xff1a;Matlab2022b Matlab对接C2000插件&#xff0c;下载连接如下 Embedded Coder Support Package for Texas Instruments C2000 Processors - File Exchange - MATLAB Central 在Matlab中加载此插件后&#xff0c;按照要求一步一步的进行就可以&#xff0c…
阅读更多...
基于 JavaScript 的富文本编辑器框架简单使用

基于 JavaScript 的富文本编辑器框架简单使用

1.打开wangEditor wangEditor开源 Web 富文本编辑器&#xff0c;开箱即用&#xff0c;配置简单https://www.wangeditor.com/ 2.html文件 <link href"https://unpkg.com/wangeditor/editorlatest/dist/css/style.css" rel"stylesheet"> <style&…
阅读更多...
qt源码--事件系统之QAbstractEventDispatcher

qt源码--事件系统之QAbstractEventDispatcher

1、QAbstractEventDispatcher内容较少&#xff0c;其主要是定义了一些注册接口&#xff0c;如定时器事件、socket事件、注册本地事件、自定义事件等等。其源码如下&#xff1a; 其主要定义了大量的纯虚函数&#xff0c;具体的实现会根据不同的系统平台&#xff0c;实现对应的方…
阅读更多...
MQTT服务器详细介绍：连接物联网的通信枢纽

MQTT服务器详细介绍：连接物联网的通信枢纽

随着物联网技术的不断发展&#xff0c;MQTT&#xff08;Message Queuing Telemetry Transport&#xff09;协议作为一种轻量级、可靠、灵活的通信协议&#xff0c;被广泛应用于物联网领域。在MQTT系统中&#xff0c;MQTT服务器扮演着重要的角色&#xff0c;作为连接物联网设备和…
阅读更多...
C高级【day2】

C高级【day2】

思维导图&#xff1a; 递归实现&#xff0c;输入一个数&#xff0c;输出这个数的每一位&#xff1a; #include<myhead.h>//递归函数 void fun(int num){//num没值不再递归if(0 num){return;}//输出数的最后一位printf("%d\t", num%10);//递归fun(num/10);}…
阅读更多...
linux du命令解析（递归计算文件子目录大小）（计算大小）（计算容量）

linux du命令解析（递归计算文件子目录大小）（计算大小）（计算容量）

文章目录 du命令简介用法常用选项示例 文档原 中文选项详细解释示例递归统计某个目录下所有文件大小&#xff08;不足单位会向上取整&#xff09;&#xff08;注意&#xff1a;可能会将目录大小也统计进去&#xff0c;目录大小为4096字节4kb&#xff1f;&#xff09; du命令使用…
阅读更多...
AI算法图形化编程加持｜OPT（奥普特）智能相机轻松适应各类检测任务

AI算法图形化编程加持｜OPT（奥普特）智能相机轻松适应各类检测任务

OPT&#xff08;奥普特&#xff09;基于SciVision视觉开发包&#xff0c;全新推出多功能一体化智能相机&#xff0c;采用图形化编程设计&#xff0c;操作简单、易用&#xff1b;不仅有上百种视觉检测算法加持&#xff0c;还支持深度学习功能&#xff0c;能轻松应对计数、定位、…
阅读更多...
Vulnhub: blogger:1靶机

Vulnhub: blogger:1靶机

kali&#xff1a;192.168.111.111 靶机&#xff1a;192.168.111.176 信息收集 端口扫描 nmap -A -sC -v -sV -T5 -p- --scripthttp-enum 192.168.111.176 在80端口的/assets/fonts/目录下发现blog目录&#xff0c;访问后发现为wordpress 利用wpscan发现wordpress插件wpdisc…
阅读更多...
发明专利申请：不能包含文本框或自选图形 || 不能包含域对象（校验错误）

发明专利申请：不能包含文本框或自选图形 || 不能包含域对象（校验错误）

提交出错 解决方案&#xff1a;如果xml文件传上去没有反应&#xff0c;一定要优先把word转成pdf&#xff0c;不要去文本框中输入&#xff1a;里面的公式编辑器很老旧&#xff08;很多公式编辑不了&#xff09; 上传以后&#xff0c;总体预览没有问题就ok&#xff0c;前序穿文件…
阅读更多...
【机器学习】处理样本不平衡的问题

【机器学习】处理样本不平衡的问题

文章目录 样本不均衡的概念及影响样本不均衡的解决方法样本层面欠采样 &#xff08;undersampling&#xff09;过采样数据增强 损失函数层面模型层面采样集成学习 决策及评估指标 样本不均衡的概念及影响 机器学习中&#xff0c;样本不均衡问题经常遇到&#xff0c;比如在金融…
阅读更多...
移动端网页div下滑消失、上滑出现（附带闪烁效果）

移动端网页div下滑消失、上滑出现（附带闪烁效果）

<div :class "IconShow ? mhomeIcon : IconOff"><img src"/assets/news.svg" alt""></div>// 距离顶部的距离const top ref(0) // 图标向上还是向下滑动const IconShow ref(true)// 滑动监听&#xff0c; 注意如果只有doc…
阅读更多...
不能乱点链接之获取cookie

不能乱点链接之获取cookie

这里是浏览器存储的某个网址的cookie 然后点击了链接就把参数获取到 因为document.cookie 会直接获取到浏览器cookie 所以为了拦截 存cookie的时候要设置&#xff1a; 设置httpOnly 只要http协议能够读取和携带 再document.cookie 就为空了 原文链接&#xff1a; 尚硅谷课程…
阅读更多...
力扣：48. 旋转图像（Python3）

力扣：48. 旋转图像（Python3）

题目&#xff1a; 给定一个 n n 的二维矩阵 matrix 表示一个图像。请你将图像顺时针旋转 90 度。 你必须在 原地 旋转图像&#xff0c;这意味着你需要直接修改输入的二维矩阵。请不要 使用另一个矩阵来旋转图像。 来源&#xff1a;力扣&#xff08;LeetCode&#xff09; 链接&…
阅读更多...
Gitignore忽略文件

Gitignore忽略文件

默认情况下&#xff0c;Git会监视我们项目中的所有内容&#xff0c;但是有些内容比如mode_modules中的内容&#xff0c;我们不希望他被Git所管理。 我们可以在我们项目目录中添加一个 .gitignore 文件来设置那些需要git忽略的文件。
阅读更多...
[C++项目] Boost文档 站内搜索引擎(2): 文档文本解析模块parser的实现、如何对文档文件去标签、如何获取文档标题...

[C++项目] Boost文档 站内搜索引擎(2): 文档文本解析模块parser的实现、如何对文档文件去标签、如何获取文档标题...

项目开始的准备工作 在上一篇文章中, 已经从Boost官网获取了Boost库的源码. 相关文章: &#x1fae6;[C项目] Boost文档 站内搜索引擎(1): 项目背景介绍、相关技术栈、相关概念介绍… 接下来就要编写代码了. 不过还需要做一些准备工作. 创建项目目录 所有的项目文件肯定要在一…
阅读更多...
C语言技巧 ----------调试----------程序员必备技能

C语言技巧 ----------调试----------程序员必备技能

作者前言 &#x1f382; ✨✨✨✨✨✨&#x1f367;&#x1f367;&#x1f367;&#x1f367;&#x1f367;&#x1f367;&#x1f367;&#x1f382; &#x1f382; 作者介绍&#xff1a; &#x1f382;&#x1f382; &#x1f382;…
阅读更多...
vue element el-upload附件上传、在线预览、下载当前预览文件

vue element el-upload附件上传、在线预览、下载当前预览文件

上传 在线预览&#xff08;iframe&#xff09;&#xff1a; payload&#xff1a; response&#xff1a; 全部代码&#xff1a; <template><div><el-table :data"tableData" border style"width: 100%"><el-table-column prop"d…
阅读更多...
从0到1开发go-tcp框架【3-读写协程分离、引入消息队列、进入连接管理器、引入连接属性】【基础篇完结】

从0到1开发go-tcp框架【3-读写协程分离、引入消息队列、进入连接管理器、引入连接属性】【基础篇完结】

从0到1开发go-tcp框架【3-读写协程分离、引入消息队列、进入连接管理器、引入连接属性】 1 读写协程分离[v0.7] 添加一个Reader和Writer之间通信的channel添加一个Writer goroutineReader由之前直接发送给客户端改为发送给通信channel启动Reader和Writer一起工作 zinx/znet/co…
阅读更多...
弹性布局，网格布局，JavaScript

弹性布局，网格布局，JavaScript

弹性盒子布局&#xff08;Flexbox Layout&#xff09;&#xff1a;通过display: flex;设置容器为弹性盒子&#xff0c;可以实现更复杂的自适应和响应式布局。 网格布局&#xff08;Grid Layout&#xff09;&#xff1a;通过display: grid;设置容器为网格布局&#xff0c;可以将…
阅读更多...
最新文章

Copyright @ 2022~2023