VBA提数据统计,速度太慢求改进代码!!

cmo9020

TEST.rar (222.61 KB, 下载次数: 35)

2022-11-26 10:37 上传

点击文件名下载附件

各位导师~周末愉快...麻烦看能不能帮忙修改代码
VBA提数据统计,速度太慢求改进代码!!
资料有1万多笔纪录,报表跑的有点辛苦...运行很慢
请老师大神们帮忙修改,看是否能快一点呢

正确的数量在"答案"工作表内
有请大神出手帮忙~谢谢各位导师们

3190496160

Sub 月统计()
Application.ScreenUpdating = False
Dim d As Object, dc As Object
Dim ar As Variant, br As Variant
Set d = CreateObject("scripting.dictionary")
Set dc = CreateObject("scripting.dictionary")
Tt = Timer
With Sheet1
    R = .Cells(Rows.Count, 1).End(xlUp).Row
    ar = .Range("a1:n" & R)
End With
With Sheet2
     rs = .Cells(Rows.Count, 1).End(xlUp).Row
     If rs > 3 Then
        .Range("a4:m" & rs).Borders.LineStyle = 0
        .Range("a4:m" & rs) = Empty
    End If
        u = UBound(ar)
        br = .Range("a3:m" & u)
        For j = 2 To UBound(br, 2)
            If Trim(br(1, j)) <> "" Then
                d(Trim(br(1, j))) = j
            End If
        Next j
        k = 1
        For i = 2 To UBound(ar)
            If Trim(ar(i, 1)) <> "" Then dc(Trim(ar(i, 1))) = dc(Trim(ar(i, 1))) + 1
            If Trim(ar(i, 1)) <> "" And Trim(ar(i, 12)) <> "" Then
                T = d(Trim(ar(i, 12)))
                If T = "" Then
                    k = k + 1
                    d(Trim(ar(i, 12))) = k
                    T = k
                    br(k, 1) = ar(i, 12)
                End If
                lh = d(Trim(ar(i, 1)))
                If lh <> "" Then
                    br(T, lh) = br(T, lh) + 1
                End If
            End If
        Next i
        k = k + 1
        br(k, 1) = "统计"
        br(k + 1, 1) = "月份总笔数"
        For j = 2 To UBound(br, 2)
            br(k, j) = Application.Sum(Application.Index(br, 0, j))
            lh = d(Trim(br(1, j)))
            br(k + 1, j) = dc(Trim(br(1, j)))
        Next j
        .[a3].Resize(k + 1, UBound(br, 2)) = br
        .[a3].Resize(k + 1, UBound(br, 2)).Borders.LineStyle = 1
End With
Set d = Nothing
Set dc = Nothing
Application.ScreenUpdating = True
MsgBox "耗时：" & Format(Timer - Tt, "0.00") & "秒"
End Sub

3190496160

TEST.rar (228.82 KB, 下载次数: 47)

2022-11-26 16:31 上传

点击文件名下载附件

3190496160

只写了月统计的代码，其他的自己依样画葫芦应该能够解决的
最后两行合计是动态的，不固定，这样才更合理吧
近9000行数据，耗时：0.11秒，速度应该不是问题吧

于箱长

3190496160 发表于 2022-11-26 16:33
只写了月统计的代码，其他的自己依样画葫芦应该能够解决的
最后两行合计是动态的，不固定，这样才更合理吧 ...

春风化雨老师厉害

cmo9020

3190496160 发表于 2022-11-26 16:31
Sub 月统计()
Application.ScreenUpdating = False
Dim d As Object, dc As Object

太感谢春风导师设计修改
再我这运行0.15秒很快非常快
实在太谢谢你大力帮忙~
小的无以回报~
只能祝假日愉快顺心

cmo9020

3190496160 发表于 2022-11-26 16:31
Sub 月统计()
Application.ScreenUpdating = False
Dim d As Object, dc As Object

突然发现漏了一件事情
原本Sheet1有进行key上日期
会顺便转成A行月份和B栏周别
您的代码比较快，能不能麻烦春风导师顺路提供一下，谢谢

3190496160

cmo9020 发表于 2022-11-26 17:59
突然发现漏了一件事情
原本Sheet1有进行key上日期
会顺便转成A行月份和B栏周别

什么意思？？？不明白

3190496160

于箱长 发表于 2022-11-26 16:44
春风化雨老师厉害

各有所长也各有所短，你的很多代码也很非常有学习的空间

cmo9020

3190496160 发表于 2022-11-26 21:12
什么意思？？？不明白

己处理完毕~谢谢导师
不过在请教最后一件事

月份总笔数  下面增加一列不良

月份总笔数   除以  统计
以%  显示第1小数点
请问导师...我需要如何变更?谢谢您~

       k = k + 2  
        br(k, 1) = "统计"
        br(k + 1, 1) = "月份总笔数"
        br(k + 2, 1) = "不良率"  
        For j = 2 To UBound(br, 2)
            br(k, j) = Application.Sum(Application.Index(br, 0, j))  
            lh = d(Trim(br(1, j)))
            br(k + 1, j) = dc(Trim(br(1, j)))              
        Next j