楼主
kevinchengcw |
Q: 如何用vba代码对进销数据进行汇总和排名？
A: 实现代码如下：- Sub test()
- Dim Dic As Object, Arr(), Arrt(), Arr2(), Result(), N&, I&, T&, A&, D#, C&, Str$, Str2$
- Set Dic = CreateObject("scripting.dictionary") '创建字典项目,用于快速汇总数据结果
- With Worksheets("进货数据") '将进货数据区内容读取到数组中
- Arr = .[a1].Resize(.Cells(.Rows.Count, 2).End(3).Row, 12).Value
- End With
- For N = LBound(Arr) + 1 To UBound(Arr) '循环进货数据各行进行数据汇总
- Str = Arr(N, 2) & vbTab & Arr(N, 4)
- Str2 = Str & vbTab & "总进货数量" '组合不同的key来储存不同的数据内容
- If Dic.exists(Str2) Then Dic(Str2) = Dic(Str2) + Arr(N, 7) Else Dic(Str2) = Arr(N, 7)
- Str2 = Str & vbTab & Arr(N, 1) & vbTab & 1 '后面的数字代表结果表中对应区下方的不同列,以克服文本的不统一(使用前提:表格格式固定且有规律)
- If Dic.exists(Str2) Then Dic(Str2) = Dic(Str2) + Arr(N, 7) Else Dic(Str2) = Arr(N, 7)
- Str2 = Str & vbTab & Arr(N, 1) & vbTab & 3
- If Dic.exists(Str2) Then Dic(Str2) = Dic(Str2) + Arr(N, 7) Else Dic(Str2) = Arr(N, 7)
- Next N
- With Worksheets("销售数据") '将销售数据区内容读取到数组中
- Arr = .[a1].Resize(.Cells(.Rows.Count, 2).End(3).Row, 11).Value
- End With
- For N = LBound(Arr) + 1 To UBound(Arr) '循环销售数据各行进行数据汇总
- Str = Arr(N, 7) & vbTab & Arr(N, 9) '组合不同的key来储存不同的数据内容
- Str2 = Str & vbTab & Arr(N, 1) & vbTab & 2 '后面的数字代表结果表中对应区下方的不同列,以克服文本的不统一(使用前提:表格格式固定且有规律)
- If Dic.exists(Str2) Then Dic(Str2) = Dic(Str2) + Arr(N, 11) Else Dic(Str2) = Arr(N, 11)
- Str2 = Str & vbTab & "总销售数量" '另添加当前区域总销售量数据统计
- If Dic.exists(Str2) Then Dic(Str2) = Dic(Str2) + Arr(N, 11) Else Dic(Str2) = Arr(N, 11)
- Next N
- With Worksheets("跟踪模板") '到跟踪模板工作表来处理结果数据
- .Range("e3", .Cells.SpecialCells(xlCellTypeLastCell)).ClearContents '清空结果数据区内容(因本例仅要求替代公式效果,故未添加自动获取销售商品清单功能)
- ReDim Arr(1 To .Cells(.Rows.Count, 3).End(3).Row - 2, 1 To 1) '初始化结果数据数组
- For N = 5 To .Cells(1, .Columns.Count).End(1).Column '循环数据区首行
- If .Cells(1, N) <> "" Then '如果单元格不为空(因有合并单元格,合并区域除首单元格外,其余都会是空)
- For I = 3 To .Cells(.Rows.Count, 3).End(3).Row '循环下方对应的数据行单元格
- If N = 5 Then Arr(I - 2, 1) = .Cells(I, 2).Value '当处理第一列时添加男女分类到数组中,用于后期排名统计
- Str = .Cells(I, 3).Value & vbTab & .Cells(I, 4).Value & vbTab & .Cells(1, N).Value '组合关键字
- If .Cells(1, N).Value Like "*区" Then '判断所处区域,如果是各区列表区,则
- If I = 3 Then ReDim Preserve Arr(LBound(Arr) To UBound(Arr), LBound(Arr, 2) To UBound(Arr, 2) + 1) '第一次处理当前区数据时在数组中添加对应数据区
- With .Cells(I, N) '开始相对当前循环到的单元格区域进行数据处理
- For T = 1 To 3 '循环各列
- Str2 = Str & vbTab & T
- If Dic.exists(Str2) Then '如果对应数据存在,则提取
- .Offset(, T - 1).Value = Dic(Str2)
- If T = 2 Then Arr(I - 2, UBound(Arr, 2)) = Dic(Str2) '如果是销售量列,则将数据添加到数组中
- End If
- Next T
- .Offset(, 3).Value = .Value - .Offset(, 1).Value - .Offset(, 2).Value '统计库存
- End With
- Else '如果不是各区数据区,则
- If Dic.exists(Str) Then '如果存在对应字典项目
- .Cells(I, N).Value = Dic(Str) '对应数据写入当前循环到的单元格
- If .Cells(1, N).Value = "总销售数量" Then '如果第一行当前循环到的列数据内容是"总销售数量",则
- If I = 3 Then ReDim Preserve Arr(LBound(Arr) To UBound(Arr), LBound(Arr, 2) To UBound(Arr, 2) + 1) '第一次循环到时添加对应数组列
- Arr(I - 2, UBound(Arr, 2)) = Dic(Str) '对应数据写入数组
- End If
- End If
- End If
- Next I
- End If
- If .Cells(1, N).Value = "总销售数量" Then '总销售量处理完成后,记录下下一列的列号,退出数据区循环
- C = N + 1
- Exit For
- End If
- Next N
- For N = LBound(Arr, 2) + 1 To UBound(Arr, 2) '循环数组第二列开始的各列,进行排名统计
- Dic.RemoveAll '清空字典内容
- For I = LBound(Arr) To UBound(Arr) '统计男女分类数据
- If Dic.exists(Arr(I, 1)) Then
- Arrt = Dic(Arr(I, 1))
- ReDim Preserve Arrt(LBound(Arrt) To UBound(Arrt) + 1)
- Arrt(UBound(Arrt)) = Arr(I, N)
- Dic(Arr(I, 1)) = Arrt
- Else
- ReDim Arrt(1 To 1)
- Arrt(1) = Arr(I, N)
- Dic(Arr(I, 1)) = Arrt
- End If
- Next I
- Arr2 = Dic.keys '提取字典项目
- For I = LBound(Arr2) To UBound(Arr2) '循环字典中各项(实际只男女两个分类)
- Arrt = Dic(Arr2(I)) '提取对应的数据数组
- If UBound(Arrt) > 1 Then '如果数组内容多于一项,则进行排序
- For T = LBound(Arrt) To UBound(Arrt) - 1
- For A = T + 1 To UBound(Arrt)
- If Val(Arrt(A)) > Val(Arrt(T)) Then
- A = Val(Arrt(A))
- Arrt(A) = Val(Arrt(T))
- Arrt(T) = A
- End If
- Next A
- Str = Arr2(I) & vbTab & Arrt(T) '排充结果与性别组合添加到字典,并记录对应的排名
- Dic(Str) = T
- Next T
- Dic(Arr2(I) & vbTab & Arrt(T)) = T
- Else
- Dic(Arr2(I) & vbTab & Arrt(1)) = 1
- End If
- Next I
- For I = LBound(Arr) To UBound(Arr) '循环将数组中对应的数值转换为排名
- Str = Arr(I, 1) & vbTab & Arr(I, N)
- Arr(I, N) = Dic(Str)
- Next I
- Next N
- ReDim Arrt(LBound(Arr) To UBound(Arr), LBound(Arr, 2) To UBound(Arr, 2) - 1) '重写义最终排名结果数组Arrt,比预处理数组Arr少了姓名一列
- For N = LBound(Arr) To UBound(Arr) '将排名结果写入最终排名结果数组Arrt
- For I = LBound(Arr, 2) + 1 To UBound(Arr, 2)
- Arrt(N, I - 1) = Arr(N, I)
- Next I
- Next N
- .Cells(3, C).Resize(UBound(Arrt), UBound(Arrt, 2)) = Arrt '排名结果写入数据区
- End With
- Set Dic = Nothing '清空字典项目
- End Sub
详见附件及素材源帖。
 模版 - 副本.rar
|