几万行的数据，现在的公式很慢，不得不求助老师

gaveout

数据多，VBA菜，请求老师的帮助，谢谢您。

小花鹿

用字典吧，以编号日期和大中小为关键字，数量相加                                                            

gaveout

小花鹿 发表于 2018-8-23 11:12
用字典吧，以编号日期和大中小为关键字，数量相加                                                       ...

老师啊，我的VBA是真的太菜了，你说的字典不懂啊

wjcmouse

数据字典处理大数据速度很快啊。我公司我是三张表，每张表60万数据。需要匹配两次，10分钟完成。

gaveout

wjcmouse 发表于 2018-8-23 11:20
数据字典处理大数据速度很快啊。我公司我是三张表，每张表60万数据。需要匹配两次，10分钟完成。

关键的问题是我不会啊老师，您可以在空闲的时间帮助一下吗？

Chip_Kenny

1. Sub zz()
   
2. Dim ar, d As Object, b(), k
   
3. Set d = CreateObject("scripting.dictionary")
   
4. ar = Sheets(1).[a1].CurrentRegion.Value
   
5. For i = 2 To UBound(ar)
   
6.     k = ar(i, 1) & "|" & ar(i, 3)
   
7.     ReDim b(30)
   
8.     If Not d.exists(k) Then
   
9.         b(ar(i, 2) - 1) = ar(i, 4)
   
10.         d(k) = b
    
11.     Else
    
12.         t = d(k)
    
13.         t(ar(i, 2) - 1) = t(ar(i, 2) - 1) + ar(i, 4)
    
14.         d(k) = t
    
15.     End If
    
16. Next
    
17. k = d.keys
    
18. For i = 0 To UBound(k) - 1
    
19.     For j = i + 1 To UBound(k)
    
20.         If k(i) > k(j) Then t = k(i): k(i) = k(j): k(j) = t
    
21.     Next
    
22. Next
    
23. ReDim ar(1 To d.Count, 1 To 35)
    
24. For i = 0 To UBound(k)
    
25.     t = Split(k(i), "|")
    
26.     ar(i + 1, 1) = t(0)
    
27.     n = 2
    
28.     For Each s In Array("大", "中", "小")
    
29.         If t(1) = s Then ar(i + 1, n) = t(1): Exit For
    
30.         n = n + 1
    
31.     Next
    
32.     t = d(k(i))
    
33.     For j = 0 To UBound(t)
    
34.         ar(i + 1, j + 5) = t(j)
    
35.     Next
    
36. Next
    
37. [d17].Resize(i, 35) = ar
    
38. End Sub

复制代码

莫名v微笑

1. Sub 测试19()
   
2. Dim arr, brr, a, b, c
   
3. Application.ScreenUpdating = False
   
4. Sheets(2).Rows(3 & ":" & Sheets(2).UsedRange.Rows.Count).ClearContents
   
5. Set d = CreateObject("scripting.dictionary")
   
6. Set d2 = CreateObject("scripting.dictionary")
   
7. arr = Sheets(1).UsedRange
   
8. For i = 2 To UBound(arr)
   
9. d(arr(i, 1) & arr(i, 3)) = arr(i, 3)
   
10. d2(arr(i, 1) & arr(i, 3) & arr(i, 2)) = d2(arr(i, 1) & arr(i, 3) & arr(i, 2)) + arr(i, 4)
    
11. Next
    
12. Sheets(2).Range("d3").Resize(d.Count) = WorksheetFunction.Transpose(d.Keys)
    
13. brr = Sheets(2).UsedRange
    
14. For i = 3 To UBound(brr)
    
15. If brr(i, 4) <> "" Then
    
16. a = Len(brr(i, 4))
    
17. b = Right(brr(i, 4), 1): c = Left(brr(i, 4), a - 1)
    
18. End If
    
19. For u = 5 To 7
    
20. If brr(i, 4) <> "" Then
    
21. brr(i, 4) = c
    
22. If brr(2, u) = b Then brr(i, u) = b: Exit For
    
23. Else: Exit For
    
24. End If
    
25. Next
    
26. Next
    
27. For i = 3 To UBound(brr)
    
28. For u = 5 To 7
    
29. For p = 8 To UBound(brr, 2)
    
30. If brr(i, u) <> "" Then
    
31. If d2.exists(brr(i, 4) & brr(2, u) & brr(2, p)) Then
    
32. brr(i, p) = d2(brr(i, 4) & brr(2, u) & brr(2, p))
    
33. End If
    
34. End If
    
35. Next
    
36. Next
    
37. Next
    
38. Sheets(2).Range("a1").Resize(UBound(brr), UBound(brr, 2)) = brr
    
39. Application.ScreenUpdating = True
    
40. Set arr = Nothing
    
41. Set brr = Nothing
    
42. End Sub

复制代码

hefuqing

1. Sub ddd()
   
2. Dim brr()
   
3. arr = Sheet1.[a1].CurrentRegion
   
4. Set d = CreateObject("scripting.dictionary")
   
5. For i = 1 To UBound(arr)
   
6. d(arr(i, 1) & "-" & arr(i, 3) & "-" & arr(i, 2)) = d(arr(i, 1) & "-" & arr(i, 3) & "-" & arr(i, 2)) + arr(i, 4)
   
7. Next i
   
8. k = d.keys
   
9. t = d.items
   
10. ReDim brr(1 To d.Count, 1 To 4)
    
11. For i = 0 To d.Count - 1
    
12. n = n + 1
    
13. brr(n, 1) = Split(k(i), "-")(0)
    
14. brr(n, 2) = Split(k(i), "-")(1)
    
15. brr(n, 3) = Split(k(i), "-")(2)
    
16. brr(n, 4) = t(i)
    
17. Next
    
18. m = 2
    
19. For i = 2 To UBound(brr)
    
20. m = m + 1
    
21. Sheet2.Cells(m, 4) = brr(i, 1)
    
22. For j = 5 To 7
    
23. If brr(i, 2) = Sheet2.Cells(2, j) Then
    
24. Sheet2.Cells(m, j) = brr(i, 2)
    
25. End If
    
26. Next j
    
27. For p = 8 To 38
    
28. If CStr(brr(i, 3)) = Sheet2.Cells(2, p).Value Then
    
29. Sheet2.Cells(m, p) = brr(i, 4)
    
30. End If
    
31. Next p
    
32. Next i
    
33. End Sub

复制代码

jjmysjg

留个记号，谢谢