一个字典代码运行的非常慢，不知道如何写入内存。

ctjr

我有个表数据量大概有十万，用字典统计每次要运行十几分钟，查了很多字典说写入内存可以提高运行效率，但是根据帖子改了好几次都失败，只能请教各位老师帮忙。把数据表里的内容统计到渠道表。原数据和代码较多，我只发了部分数据和代码。这个是代码

1. Sub 测试()
   
2. 
   
3.     With ThisWorkbook.Sheets("数据表")
   
4.     Set dic1 = CreateObject("scripting.dictionary")
   
5.     Set dic2 = CreateObject("scripting.dictionary")
   
6.         For i = 2 To .UsedRange.Rows.Count
   
7.                 dic1(.Cells(i, 2) & .Cells(i, 3) & .Cells(i, 4)) = dic1(.Cells(i, 2) & .Cells(i, 3) & .Cells(i, 4)) + 1
   
8.             If .Cells(i, 5) = "是" Then
   
9.                 dic2(.Cells(i, 2) & .Cells(i, 3) & .Cells(i, 4)) = dic2(.Cells(i, 2) & .Cells(i, 3) & .Cells(i, 4)) + 1
   
10.             End If
    
11.         Next
    
12.     End With
    
13. 
    
14.     With ThisWorkbook.Sheets("渠道表")
    
15.         For i = 2 To .UsedRange.Rows.Count
    
16.             .Cells(i, 4) = dic1(.Cells(i, 1) & .Cells(i, 2) & .Cells(i, 3))
    
17.             .Cells(i, 5) = dic2(.Cells(i, 1) & .Cells(i, 2) & .Cells(i, 3))
    
18.         Next
    
19.     End With
    
20. 
    
21. End Sub
    
22. 
    

复制代码

这个是附件，谢谢各位。

测试.rar (23.15 KB, 下载次数: 13)

2021-5-12 10:43 上传

点击文件名下载附件

3190496160

目前的代码虽然用字典，但直接频繁操单元格，速度肯定是慢的，用数组十字典，儿十万行速度不是问题

xuqing8331

供楼主参考。。。

hongshan2019

10万行还不数组走起。。。

A1233515

字典的最佳搭档就是数组
单元格操作太费时

gugudeai

=UNIQUE(数据表!B2:D100000)
=COUNTIFS(数据表!$B$2:$B$100000,A2,数据表!$C$2:$C$100000,B2,数据表!$D$2:$D$100000,C2)
这两个函数完全可以胜任

ctjr

谢谢各位老师指点，我研究研究数组

chxw68

1. Sub test()
   
2.   Dim r&, i&
   
3.   Dim arr, brr
   
4.   Dim d As Object
   
5.   Application.ScreenUpdating = False
   
6.   Application.DisplayAlerts = False
   
7.   Set d = CreateObject("scripting.dictionary")
   
8.   With Worksheets("数据表")
   
9.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
   
10.     arr = .Range("a2:e" & r)
    
11.   End With
    
12.   For i = 1 To UBound(arr)
    
13.     xm = arr(i, 2) & "+" & arr(i, 3) & "+" & arr(i, 4)
    
14.     If Not d.exists(xm) Then
    
15.       ReDim brr(1 To 5)
    
16.       brr(1) = arr(i, 2)
    
17.       brr(2) = arr(i, 3)
    
18.       brr(3) = arr(i, 4)
    
19.     Else
    
20.       brr = d(xm)
    
21.     End If
    
22.     brr(4) = brr(4) + 1
    
23.     If arr(i, 5) = "是" Then
    
24.       brr(5) = brr(5) + 1
    
25.     End If
    
26.     d(xm) = brr
    
27.   Next
    
28.   ReDim crr(1 To d.Count, 1 To 5)
    
29.   m = 0
    
30.   For Each aa In d.keys
    
31.     brr = d(aa)
    
32.     m = m + 1
    
33.     For j = 1 To UBound(brr)
    
34.       crr(m, j) = brr(j)
    
35.     Next
    
36.   Next
    
37.   With Worksheets("渠道表")
    
38.     .UsedRange.Offset(1, 0).ClearContents
    
39.     .Range("a2").Resize(m, UBound(crr, 2)) = crr
    
40.   End With
    
41. End Sub
    

复制代码

chxw68

详见附件。

chxw68

1. Sub test2()
   
2.   Dim sql As String
   
3.   Dim mybook As String
   
4.   Dim cnn As Object
   
5.   Dim rs As Object
   
6.   Set cnn = CreateObject("adodb.connection")
   
7.   Set rs = CreateObject("adodb.recordset")
   
8.   mybook = ThisWorkbook.FullName
   
9.   With cnn
   
10.     If Application.Version = "11.0" Then
    
11.       .Provider = "microsoft.jet.oledb.4.0"
    
12.       .ConnectionString = "extended properties=""excel 8.0;HDR=YES;IMEX=1"";data source=" & mybook
    
13.     Else
    
14.       .Provider = "microsoft.ACE.oledb.12.0"
    
15.       .ConnectionString = "extended properties=""excel 12.0;HDR=YES;IMEX=1"";data source=" & mybook
    
16.     End If
    
17.     .Open
    
18.   End With
    
19.   sql = "select 县市,地市,门店名称,count(是否有效) as 总数,sum(iif(是否有效='是',1,0)) as 有效数 from [数据表$a1:e] group by 县市,地市,门店名称"
    
20.   rs.Open sql, cnn, adOpenKeyset, adLockOptimistic
    
21.   With Worksheets("渠道表")
    
22.     .UsedRange.Offset(1, 0).Clear
    
23.     .Range("a2").CopyFromRecordset rs
    
24.   End With
    
25. End Sub
    

复制代码