数据汇总

feilanga

下了夏天-17 发表于 2023-6-5 15:31
老师，能否给您的代码加个备注

1. Sub ykcbf()
   
2.     Application.ScreenUpdating = False '关闭屏幕更新以加快处理速度
   
3.     Application.DisplayAlerts = False '关闭警告信息以避免干扰
   
4.     Dim arr, brr, d '定义数组和字典对象
   
5.     Set d = CreateObject("Scripting.Dictionary") '创建字典对象
   
6.     Set zwb = ThisWorkbook '获取当前工作簿
   
7.     p = ThisWorkbook.Path '获取工作簿所在路径
   
8.     f = p & "\基础数据.xlsx" '拼接基础数据文件的路径
   
9.     Set wb = Workbooks.Open(f, 0) '打开基础数据文件
   
10.     For Each sht In wb.Sheets '遍历每个工作表
    
11.         With sht
    
12.             arr = .UsedRange '获取工作表的数据范围
    
13.             s = Split(.[a2], "：")(1) & "|" & Split(.[d2], "：")(1) '获取物资名称和客户经理名字，并用管道符拼接成字符串
    
14.             mc = Split(.[a3], "：")(1) '获取仓库名称
    
15.             dm = Split(.[d3], "：")(1) '获取仓库代码
    
16.         End With
    
17.         For i = 5 To UBound(arr) '遍历每一行数据
    
18.             If arr(i, 2) <> Empty Then '如果第二列不为空
    
19.                 ss = arr(i, 2) & "|" & mc '获取物资名称和仓库名称，并用管道符拼接成字符串
    
20.                 If Not d.exists(s) Then Set d(s) = CreateObject("Scripting.Dictionary") '如果字典中没有该物资和客户经理组合的键，则创建
    
21.                 If Not d(s).exists(ss) Then '如果字典中该物资和客户经理组合的键没有该物资和仓库名称组合的键，则创建
    
22.                     d(s)(ss) = Array(arr(i, 2), arr(i, 3), mc, dm) '将该行数据存储到字典中
    
23.                 End If
    
24.             End If
    
25.         Next
    
26.     Next
    
27.     wb.Close False '关闭基础数据文件，不保存
    
28.     For Each sht In zwb.Sheets '遍历当前工作簿的所有工作表
    
29.         If sht.Name <> "模板" Then sht.Delete '删除除了模板以外的工作表
    
30.     Next
    
31.     For Each k In d.keys '遍历字典中的键
    
32.         m = 0: ReDim brr(1 To 1000, 1 To 4) '初始化计数器和数组
    
33.         Set sht = Sheets.Add(after:=Sheets(Sheets.Count)) '在当前工作簿中添加一个新的工作表
    
34.         With sht
    
35.             b = Split(k, "|") '将物资名称和客户经理分离成数组
    
36.             .Name = b(0) & b(1) '将物资名称和客户经理拼接成工作表名称
    
37.             Sheets("模板").Cells.Copy .[a1] '复制模板工作表中的单元格到新的工作表
    
38.             .[a2] = "物资名称：" & b(0) '在新工作表中填写物资名称和客户经理名称
    
39.             .[f2] = "客户经理：" & b(1)
    
40.             .DrawingObjects.Delete '删除绘图对象以加快处理速度
    
41.             For Each kk In d(k).keys '遍历字典中的值
    
42.                 m = m + 1 '计数器加1
    
43.                 t = d(k)(kk) '获取该行数据
    
44.                 For x = 1 To 4 '遍历该行数据的4列
    
45.                     brr(m, x) = t(x - 1) '将该行数据存入数组中
    
46.                 Next
    
47.             Next
    
48.             .[d5].Resize(m, 4) = brr '将数组中的数据写入新工作表中
    
49.         End With
    
50.     Next
    
51.     Application.ScreenUpdating = True '打开屏幕更新
    
52. End Sub

复制代码

本注释由郑广学VBA代码助手ai自动生成

3190496160

Sub 汇总()
Application.ScreenUpdating = False
Dim ar As Variant
Dim i As Long, r As Long
Dim br(), brr()
Dim d As Object
Set sht = ThisWorkbook.Worksheets("模板")
Set d = CreateObject("scripting.dictionary")
ReDim br(1 To 100000, 1 To 6)
For Each sh In Sheets
    If sh.Name <> "模板" Then
        r = sh.Cells(Rows.Count, 2).End(xlUp).Row
        ar = sh.Range("a1:f" & r)
        For i = 5 To UBound(ar)
            If Trim(ar(i, 2)) <> "" Then
                n = n + 1
                br(n, 1) = ar(i, 2)
                br(n, 2) = ar(i, 3)
                br(n, 3) = Replace(ar(3, 1), "零售户名称：", "")
                br(n, 4) = Replace(ar(3, 4), "客户代码：", "")
                br(n, 5) = Replace(ar(2, 4), "客户经理：", "")
                br(n, 6) = Replace(ar(2, 1), "物资名称：", "")
                zd = br(n, 5) & "-" & br(n, 6)
                d(zd) = ""
            End If
        Next i
    End If
Next sh
If n = "" Then End
For Each k In d.keys
    m = 0: s = s + 1
    ReDim brr(1 To n, 1 To 4)
    For i = 1 To n
        zd = br(i, 5) & "-" & br(i, 6)
        If zd = k Then
            m = m + 1
            For j = 1 To 4
                brr(m, j) = br(i, j)
            Next j
        End If
    Next i
    If s = 1 Then
        sht.Copy
        Set wb = ActiveWorkbook
        With wb.Worksheets(1)
            .Name = k
            .[f2] = "物资名称：" & Split(k, "-")(0)
            .[a2] = "客户经理：" & Split(k, "-")(0)
            .[d5].Resize(m, UBound(brr, 2)) = brr
        End With
    Else
        sht.Copy after:=wb.Worksheets(wb.Worksheets.Count)
        With wb.ActiveSheet
            .Name = k
            .[f2] = "物资名称：" & Split(k, "-")(0)
            .[a2] = "客户经理：" & Split(k, "-")(0)
            .[d5].Resize(m, UBound(brr, 2)) = brr
        End With
    End If
Next k
wb.SaveAs Filename:=ThisWorkbook.Path & "\发放物资汇总台账" & Format(Date, "yyyymmdd") & ".xlsx"
Set d = Nothing
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub

3190496160

基础数据.rar (29.68 KB, 下载次数: 7)

2023-6-5 16:03 上传

点击文件名下载附件

3190496160

下了夏天-17

ykcbf1100 发表于 2023-6-5 15:56
能正常使用吗？

能正常用的，老师。方便的话加个备注，我学习一下

下了夏天-17

ykcbf1100 发表于 2023-6-5 15:18
附件供参考。。。

老师，还需要在发放物资台账汇总表中自动汇总“备注”列的数据，请问如何修改代码

下了夏天-17

feilanga 发表于 2023-6-5 15:57
本注释由郑广学VBA代码助手ai自动生成

老师，还需要在发放物资台账汇总表中自动汇总“备注”列的数据，请问如何修改代码

ykcbf1100

下了夏天-17 发表于 2023-6-6 15:49
老师，还需要在发放物资台账汇总表中自动汇总“备注”列的数据，请问如何修改代码

修改好了。

下了夏天-17

ykcbf1100 发表于 2023-6-5 15:18
附件供参考。。。

自动分类填充
https://club.excelhome.net/thread-1664782-1-1.html
(出处: ExcelHome技术论坛)
老师，能否帮忙看下这个问题