Excel VBA如何实现多字段分组去重汇总TEUS、Empty Container及Pick Up

核心实现思路 #

使用字典对象完成分组匹配与指标聚合，执行效率远高于逐行嵌套循环判断：

• 以6个分组维度的字段拼接值作为字典唯一键，自动归集同组条目
• 以字典项存储每个分组对应的三类指标累计值
• 一次遍历原始数据完成所有组的指标累计，遍历结束后批量将结果写入输出表

分步骤实现逻辑 #

1. 前置去重处理：直接基于RawData表的Reference Number列移除重复条目，避免重复单据干扰统计结果

   Dim rawWs As Worksheet
   Set rawWs = ThisWorkbook.Worksheets("RawData")
   ' 动态定位Reference Number列位置
   Dim refCol As Long
   refCol = rawWs.Rows(1).Find(What:="Reference Number", LookAt:=xlWhole).Column
   ' 执行去重
   rawWs.UsedRange.RemoveDuplicates Columns:=refCol, Header:=xlYes
   

2. 动态获取所有依赖字段的列号：通过表头匹配定位所有需要用到的字段列，避免硬编码列号导致原始表列顺序调整后代码失效

   Dim colCar As Long, colTrade As Long, colProduct As Long
   Dim colService As Long, colPort As Long, colDate As Long
   Dim colTEUS As Long, colContainer As Long, colPickUp As Long
   ' 逐列匹配字段位置
   colCar = rawWs.Rows(1).Find(What:="Car", LookAt:=xlWhole).Column
   colTrade = rawWs.Rows(1).Find(What:="Trade name", LookAt:=xlWhole).Column
   colProduct = rawWs.Rows(1).Find(What:="Product", LookAt:=xlWhole).Column
   colService = rawWs.Rows(1).Find(What:="service", LookAt:=xlWhole).Column
   colPort = rawWs.Rows(1).Find(What:="Port", LookAt:=xlWhole).Column
   colDate = rawWs.Rows(1).Find(What:="Date", LookAt:=xlWhole).Column
   colTEUS = rawWs.Rows(1).Find(What:="Total TEUS", LookAt:=xlWhole).Column
   colContainer = rawWs.Rows(1).Find(What:="Container", LookAt:=xlWhole).Column
   colPickUp = rawWs.Rows(1).Find(What:="Pick Up", LookAt:=xlWhole).Column
   

3. 逐行遍历完成分组累计：遍历去重后的原始数据，完成同组归集与指标值计算

   Dim dict As Object
   Set dict = CreateObject("Scripting.Dictionary")
   ' 从第2行开始遍历（跳过表头行）
   Dim i As Long
   For i = 2 To rawWs.UsedRange.Rows.Count
       ' 拼接分组键，使用|作为分隔符，避免字段值被误拆分
       Dim groupKey As String
       groupKey = Join(Array( _
           rawWs.Cells(i, colCar).Value, _
           rawWs.Cells(i, colTrade).Value, _
           rawWs.Cells(i, colProduct).Value, _
           rawWs.Cells(i, colService).Value, _
           rawWs.Cells(i, colPort).Value, _
           rawWs.Cells(i, colDate).Value _
       ), "|")
       ' 初始化分组项结构：数组顺序为[TEUS累计值, 空箱计数, PickUp累计值]
       If Not dict.Exists(groupKey) Then
           dict(groupKey) = Array(0, 0, 0)
       End If
       ' 读取当前分组的累计值，逐行更新
       Dim tempArr As Variant
       tempArr = dict(groupKey)
       ' 累计Total TEUS值
       tempArr(0) = tempArr(0) + rawWs.Cells(i, colTEUS).Value
       ' 判断Container列是否为空，累计空箱数量
       If Trim(CStr(rawWs.Cells(i, colContainer).Value)) = "" Then
           tempArr(1) = tempArr(1) + 1
       End If
       ' 累计Pick Up值
       tempArr(2) = tempArr(2) + rawWs.Cells(i, colPickUp).Value
       ' 将更新后的累计值回写到字典
       dict(groupKey) = tempArr
   Next i
   

4. 结果写入输出表：遍历字典的所有分组结果，写入Forecast工作表，替换原有直接复制字段的冗余逻辑

   Dim outWs As Worksheet
   Set outWs = ThisWorkbook.Worksheets("Forecast")
   Dim outRow As Long
   outRow = 2 ' 从第2行开始写入，跳过已配置的表头
   ' 逐组输出结果
   Dim k As Variant
   For Each k In dict.Keys
       ' 拆分分组键，写回6个维度的字段值
       Dim keyParts As Variant
       keyParts = Split(k, "|")
       outWs.Cells(outRow, colCar).Value = keyParts(0)
       outWs.Cells(outRow, colTrade).Value = keyParts(1)
       outWs.Cells(outRow, colProduct).Value = keyParts(2)
       outWs.Cells(outRow, colService).Value = keyParts(3)
       outWs.Cells(outRow, colPort).Value = keyParts(4)
       outWs.Cells(outRow, colDate).Value = keyParts(5)
       ' 写回三个统计指标值
       outWs.Cells(outRow, outWs.Rows(1).Find(What:="Total TEUS", LookAt:=xlWhole).Column).Value = dict(k)(0)
       outWs.Cells(outRow, outWs.Rows(1).Find(What:="Empty Container", LookAt:=xlWhole).Column).Value = dict(k)(1)
       outWs.Cells(outRow, outWs.Rows(1).Find(What:="Pick Up", LookAt:=xlWhole).Column).Value = dict(k)(2)
       outRow = outRow + 1
   Next k
   

性能优化提示 #

• 遍历原始数据前，关闭屏幕更新、自动计算功能，数据量较大时可将执行速度提升10倍以上
• 拼接分组键时，需统一所有字段值的文本格式（比如转成字符串、去掉两端空格），避免同维度值因格式差异被误判为不同组
• 处理完成后记得恢复屏幕更新与自动计算设置

内容的提问来源于stack exchange，提问作者devilgg86