请帮忙写一下VBA代码，有上万条数据，自己能力有限弄了几天都不行。

wang80tie

请帮忙写一下VBA代码，有上万条数据，自己能力有限弄了几天都不行。

ykcbf1100

附件供参考。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()   '//2024.12.12
   
2.     Application.ScreenUpdating = False
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.     Set d1 = CreateObject("Scripting.Dictionary")
   
5.     With Sheets("GZ")
   
6.         r = .Cells(Rows.Count, 1).End(3).Row
   
7.         c = .UsedRange.Columns.Count
   
8.         arr = .[a1].Resize(r, c)
   
9.     End With
   
10.     For i = 2 To UBound(arr)
    
11.         s = CStr(arr(i, 1))
    
12.         d1(s) = arr(i, 2)
    
13.         s = CStr(arr(i, 1)) & "|" & arr(i, 4)
    
14.         d(s) = Array(arr(i, 5), arr(i, 6))
    
15.     Next
    
16.     With Sheets("GZHZ")
    
17.         r = .Cells(Rows.Count, 1).End(3).Row
    
18.         c = .UsedRange.Columns.Count
    
19.         c1 = .Rows(1).Find("补发").Column
    
20.         arr = .[a1].Resize(r, c)
    
21.         .[a1].Resize(r, c).Borders.LineStyle = 1
    
22.         For i = 2 To UBound(arr)
    
23.             s = CStr(arr(i, 1))
    
24.             If d1.exists(s) Then
    
25.                 .Cells(i, 2) = d1(s)
    
26.             End If
    
27.             Sum = 0
    
28.             For j = 3 To c1 - 1
    
29.                 s = CStr(arr(i, 1)) & "|" & arr(1, j)
    
30.                 If d.exists(s) Then
    
31.                     .Cells(i, j) = d(s)(0)
    
32.                     Sum = Sum + d(s)(1)
    
33.                 End If
    
34.             Next
    
35.             .Cells(i, c1) = Sum
    
36.             .Cells(i, c1 + 1) = .Cells(i, c1) + Application.Sum(.Cells(i, 3).Resize(, c1 - 3))
    
37.             .Cells(i, c1 + 2) = Round(.Cells(i, c1 + 1) / 12, 0)
    
38.         Next
    
39.     End With
    
40.     Set d = Nothing
    
41.     Application.ScreenUpdating = True
    
42.     MsgBox "OK！"
    
43. End Sub
    

复制代码

wang80tie

ykcbf1100 发表于 2024-12-12 10:30
参与一下。。。

非常感谢，收藏学习

wang80tie

ykcbf1100 发表于 2024-12-12 10:29
附件供参考。。。

非常感谢

usedrange

联系一下拆表，数组加字典金典组合。。。。

usedrange

上个附件吧。。。。。

chxw68

1. Sub test()
   
2.     Dim r%, i%
   
3.     Dim arr, brr
   
4.     Dim d As Object
   
5.     Set d1 = CreateObject("scripting.dictionary")
   
6.     Set d2 = CreateObject("scripting.dictionary")
   
7.     With Worksheets("GZHZ")
   
8.         r = .Cells(.Rows.Count, 1).End(xlUp).Row
   
9.         c = .Cells(1, .Columns.Count).End(xlToLeft).Column
   
10.         .Range("b2").Resize(r - 1, c - 1).ClearContents
    
11.         arr = .Range("a1").Resize(r, c)
    
12.         For i = 2 To UBound(arr)
    
13.             d1(arr(i, 1)) = i
    
14.         Next
    
15.         For j = 2 To UBound(arr, 2)
    
16.             d2(arr(1, j)) = j
    
17.         Next
    
18.     End With
    
19.     With Worksheets("GZ")
    
20.         r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
21.         brr = .Range("a2:g" & r)
    
22.     End With
    
23.     For i = 1 To UBound(brr)
    
24.         If d1.exists(brr(i, 1)) Then
    
25.             m = d1(brr(i, 1))
    
26.             arr(m, 2) = brr(i, 2)
    
27.             If d2.exists(brr(i, 4)) Then
    
28.                 n = d2(brr(i, 4))
    
29.                 arr(m, n) = brr(i, 5)
    
30.                 arr(m, 16) = arr(m, 16) + brr(i, 6)
    
31.             End If
    
32.         End If
    
33.     Next
    
34.     For i = 2 To UBound(arr)
    
35.         For j = 3 To 16
    
36.             arr(i, 17) = arr(i, 17) + arr(i, j)
    
37.         Next
    
38.         arr(i, 18) = Application.Round(arr(i, 17) / 12, 0)
    
39.     Next
    
40.     With Worksheets("GZHZ")
    
41.         .Range("a1").Resize(UBound(arr), UBound(arr, 2)) = arr
    
42.     End With
    
43. End Sub
    

复制代码

chxw68

参与一下。

jjmysjg

月份自动取值就更完美了