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

news2024/10/5 16:24:18

在这里插入图片描述
如图：对图中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-一个装箱难题》

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

如若内容造成侵权/违法违规/事实不符，请联系多彩编程网进行投诉反馈，一经查实，立即删除！

相关文章

数据结构--动态顺序表

数据结构--动态顺序表

文章目录 线性表动态顺序表数组与顺序表 接口实现初始化&#xff1a;尾插&#xff1a;尾删头插头删指定位置插入指定位置删除查找摧毁 完整代码 线性表 线性表是数据结构中最基本、最简单也是最常用的一种数据结构。线性表是指由n个具有相同数据类型的元素组成的有限序列。 线…
阅读更多...
Kubernetes （k8s）理论介绍

Kubernetes （k8s）理论介绍

一&#xff1a;K8s 简介 1、K8s作用 2、K8s 来历 3、为什么要用 K8S? 4、Kubernetes 功能 二&#xff1a;Kubernetes 集群架构与组件 1、Kubernetes 集群架构与组件 2、核心组件 -Master 组件 &#xff08;1&#xff09;Kube-apiserver &#xff08;2&#xff09;Kube…
阅读更多...
Wiki知识库项目-全流程笔记

Wiki知识库项目-全流程笔记

第一章 第二章 2.1本章项目流程 2.2创建springboot项目 2.2.1修改springboot的版本号为 2.4.0 2.2.3将代码交给git进行管理 2-5修改日志样式 2.5.1将springboot项目打印日志样式进行修改。创建logback-spring.xml文件夹&#xff0c;文件与application.xml文件位置并列。 &l…
阅读更多...
图书借阅系统 SSM框架

图书借阅系统 SSM框架

步骤一&#xff1a;创建数据库、表 步骤二&#xff1a;创建工程、包、pom依赖 步骤三&#xff1a;web.xml 步骤四&#xff1a;applicationContext.xml 步骤五&#xff1a;mybatis-config.xml 步骤六&#xff1a;实体类 步骤七&#xff1a;BookInfoMapper 步骤八&#xff1a; 步…
阅读更多...
小白到运维工程师自学之路 第六十一集 （docker容器的操作）

小白到运维工程师自学之路 第六十一集 （docker容器的操作）

1、创建容器与运行容器 docker create -it nginx /bin/bash -i 让容器的输入保持打开 -t 让Docker 分配一个伪终端 -d 守护进程形式运行 使用docker create 命令创建新容器后会返回一个唯一的ID 2、查看运行状态 docker ps -a 可以使用docker ps 命令来查看所有容器的运行状态…
阅读更多...
未能加载文件或程序集“System.CodeDom, Version=4.0.2.0。。。或它的某一个依赖项。系统找不到指定的文件

未能加载文件或程序集“System.CodeDom, Version=4.0.2.0。。。或它的某一个依赖项。系统找不到指定的文件

winform未能加载文件或程序集“System.CodeDom, Version4.0.2.0, Cultureneutral, PublicKeyTokencc7b13ffcd2ddd51”或它的某一个依赖项。系统找不到指定的文件。 触发原因解决方法 触发原因 在NuGet中安装IronPython时&#xff0c;由于一直提示缺少依赖&#xff0c;所以在安…
阅读更多...
长度最小的子数组_力扣209

长度最小的子数组_力扣209

文章目录 题目描述法一 滑动窗口法 题目描述 法一 滑动窗口法 int minSubArrayLen(int target, vector<int>&nums){int n nums.size();int cnt INT_MAX;int start0, end0, sum0;while(end<n){sum nums[end];while(sum>target){cnt min(cnt, end-start1);su…
阅读更多...
智慧灯杆四大应用场景

智慧灯杆四大应用场景

智慧灯杆是一种通过集成先进技术和智能系统的道路照明设施。它不仅具备传统灯杆的基本功能&#xff0c;还具有灯具、传感器、通信设备、监控摄像头等多个功能模块。可以实现智能照明、环境监测、安全监控、交通管理等多种功能&#xff0c;为城市的智慧化建设和市民的生活提供更…
阅读更多...
html：去除input/textarea标签的拼写检查

html：去除input/textarea标签的拼写检查

默认情况下&#xff0c;textarea 会启动拼写和语法检查&#xff0c;表现效果就是单词拼写错误会出现红色下划线提示 <textarea></textarea>效果 有时&#xff0c;我们并不需要拼写检查&#xff0c;可以通过配置属性spellcheck"false" 去除拼写和语法检…
阅读更多...
【打表】ccpc 2022威海 G

【打表】ccpc 2022威海 G

Problem - G - Codeforces 题意&#xff1a; 思路&#xff1a; 这种题大概率只能打表 把gcd(kx^x,x)的值打出来&#xff0c;可以发现是个循环节 Code&#xff1a; #include <bits/stdc.h>#define int long longusing namespace std;const int mxn1e610; const int mx…
阅读更多...
PHP使用PhpSpreadsheet实现导出Excel时带下拉框列表 (可支持三级联动)

PHP使用PhpSpreadsheet实现导出Excel时带下拉框列表 (可支持三级联动)

因项目需要导出Excel表 需要支持下拉 且 还需要支持三级联动功能 目前应为PHPExcel 不在维护&#xff0c;固采用 PhpSpreadsheet 效果如图&#xff1a; 第一步&#xff1a;首先 使用composer 获取PhpSpreadsheet 我这里PHP 版本 7.4 命令如下&#xff1a; composer r…
阅读更多...
【Linux命令200例】rm用来删除文件或目录（谨慎使用）

【Linux命令200例】rm用来删除文件或目录（谨慎使用）

&#x1f3c6;作者简介&#xff0c;黑夜开发者&#xff0c;全栈领域新星创作者✌&#xff0c;阿里云社区专家博主&#xff0c;2023年6月csdn上海赛道top4。 &#x1f3c6;本文已收录于专栏&#xff1a;Linux命令大全。 &#x1f3c6;本专栏我们会通过具体的系统的命令讲解加上鲜…
阅读更多...
1.3 网络空间安全政策与标准

1.3 网络空间安全政策与标准

数据参考&#xff1a;CISP官方 目录 网络安全国家战略网络安全标准体系网络安全等级保护网络安全职业道德 一、网络安全国家战略 1、国家指导政策 《中华人民共和国网络安全法》&#xff1a;该法律于2016年出台&#xff0c;2017年6月1日正式生效。它是中国网络安全领域的基…
阅读更多...
Kylin v10基于cephadm工具离线部署ceph分布式存储

Kylin v10基于cephadm工具离线部署ceph分布式存储

1. 环境&#xff1a; ceph&#xff1a;octopus OS&#xff1a;Kylin-Server-V10_U1-Release-Build02-20210824-GFB-x86_64、CentOS Linux release 7.9.2009 2. ceph和cephadm 2.1 ceph简介 Ceph可用于向云平台提供对象存储、块设备服务和文件系统。所有Ceph存储集群部署都从…
阅读更多...
基于Spring Boot的美食分享网站设计与实现（Java+spring boot+MySQL）

基于Spring Boot的美食分享网站设计与实现（Java+spring boot+MySQL）

获取源码或者论文请私信博主 演示视频&#xff1a; 基于Spring Boot的美食分享网站设计与实现&#xff08;Javaspring bootMySQL&#xff09; 使用技术&#xff1a; 前端&#xff1a;html css javascript jQuery ajax thymeleaf 微信小程序 后端&#xff1a;Java springboot…
阅读更多...
数控机床主轴品牌选择及选型，如何维护和保养？

数控机床主轴品牌选择及选型，如何维护和保养？

数控机床主轴品牌选择及选型&#xff0c;如何维护和保养&#xff1f; 数控机床是一种高精度、高效率、高自动化的机床。其中&#xff0c;主轴是数控机床的核心部件&#xff0c;承担着转动工件、切削加工的任务&#xff0c;决定了加工的转速、切削力度和加工效率。因此&#xff…
阅读更多...
C++入门教程||C++地图用法

C++入门教程||C++地图用法

C地图用法 C 中 map 提供的是一种键值对容器&#xff0c;里面的数据都是成对出现的&#xff0c;如下图&#xff1a;每一对中的第一个值称之为关键字&#xff08;key&#xff09;&#xff0c;每个关键字只能在 map 中出现一次;第二个称之为该关键字的对应值。在一些程序中建立一…
阅读更多...
最难用的鼠标键、设置半天、反人类逻辑（罗技）

最难用的鼠标键、设置半天、反人类逻辑（罗技）

目的&#xff1a;高效设置罗技鼠标键&#xff0c;提高复制粘贴效率 准备软件&#xff1a;Logitech G HUB – Logitech 支持 下载 1、右上角&#xff0c;点击箭头、点击管理配置文件 2、左下角、点击加号&#xff0c;创建配置文件“办公” 3、点击办公 4、右上角选择“办公”…
阅读更多...
蓝桥云课ROS机器人旧版实验报告-01入门

蓝桥云课ROS机器人旧版实验报告-01入门

项目名称 实验一 ROS[Kinetic/Melodic/Noetic]入门 成绩 设计要求&#xff1a; 机器人操作系统安装、虚拟机、Docker、嵌入式系统 实验记录&#xff08;70分&#xff09; 1.以 $ 开头的行是终端命令。 - 要打开一个新终端 → 使用快捷键 ctrlaltt。 - 要在现有终端内…
阅读更多...
Mac端口扫描工具

Mac端口扫描工具

端口扫描工具 Mac内置了一个网络工具 网络使用工具 按住 Command 空格 然后搜索 “网络实用工具” 或 “Network Utility” 即可 域名/ip转换Lookup ping功能 端口扫描 https://zhhll.icu/2022/Mac/端口扫描工具/ 本文由 mdnice 多平台发布
阅读更多...
推荐文章
最新文章

Copyright @ 2022~2023