[已解决]求助：简化代码

liuxingyi88

Sub niantj()
Dim d As New Dictionary
Dim D1 As New Dictionary
Dim D2 As New Dictionary
Dim D3 As New Dictionary
Dim D4 As New Dictionary
Dim D5 As New Dictionary
Dim D6 As New Dictionary
Dim D7 As New Dictionary
Dim D8 As New Dictionary
Dim i As Long
With Sheets("录入")
For i = 1 To .Range("E1048576").End(xlUp).Row
d(.Cells(i, 5).Value) = d(.Cells(i, 5).Value) + .Cells(i, 8).Value
D1(.Cells(i, 5).Value) = D1(.Cells(i, 5).Value) + .Cells(i, 10).Value
D2(.Cells(i, 5).Value) = D2(.Cells(i, 5).Value) + .Cells(i, 11).Value
D3(.Cells(i, 5).Value) = D3(.Cells(i, 5).Value) + .Cells(i, 12).Value
D4(.Cells(i, 5).Value) = D4(.Cells(i, 5).Value) + .Cells(i, 13).Value
D5(.Cells(i, 5).Value) = D5(.Cells(i, 5).Value) + .Cells(i, 14).Value
D6(.Cells(i, 5).Value) = D6(.Cells(i, 5).Value) + .Cells(i, 15).Value
D7(.Cells(i, 5).Value) = D7(.Cells(i, 5).Value) + .Cells(i, 16).Value
D8(.Cells(i, 5).Value) = D8(.Cells(i, 5).Value) + .Cells(i, 17).Value
Next i
End With
With Sheets("编号")
.Range("a2").Resize(d.Count, 1) = Application.WorksheetFunction.Transpose(d.Keys)
.Range("b2").Resize(d.Count, 1) = Application.WorksheetFunction.Transpose(d.Items)
.Range("C2").Resize(d.Count, 1) = Application.WorksheetFunction.Transpose(D1.Items)
.Range("d2").Resize(d.Count, 1) = Application.WorksheetFunction.Transpose(D2.Items)
.Range("e2").Resize(d.Count, 1) = Application.WorksheetFunction.Transpose(D3.Items)
.Range("f2").Resize(d.Count, 1) = Application.WorksheetFunction.Transpose(D4.Items)
.Range("g2").Resize(d.Count, 1) = Application.WorksheetFunction.Transpose(D5.Items)
.Range("h2").Resize(d.Count, 1) = Application.WorksheetFunction.Transpose(D6.Items)
.Range("i2").Resize(d.Count, 1) = Application.WorksheetFunction.Transpose(D7.Items)
.Range("j2").Resize(d.Count, 1) = Application.WorksheetFunction.Transpose(D8.Items)
End With
End Sub

最佳答案

月排行榜 / 总排行榜

mxg825

2011-11-23 00:37

再优化一次

1. Sub niantj()
   
2. Dim d As New Dictionary
   
3. Dim i As Long, K As Long, R As Long, X As Integer
   
4. Dim ARR, BRR
   
5. 
   
6. ARR = Sheets("录入").UsedRange
   
7.     For i = 1 To UBound(ARR)
   
8.         If Not d.Exists(ARR(i, 5)) Then
   
9.             K = K + 1
   
10.             d(ARR(i, 5)) = K
    
11.             ReDim Preserve BRR(1 To 10, 1 To K)
    
12.             BRR(1, K) = ARR(i, 5)
    
13.         End If
    
14.         R = d(ARR(i, 5))
    
15.         BRR(2, R) = BRR(2, R) + ARR(i, 8)
    
16.         For X = 3 To 10
    
17.            BRR(X, R) = BRR(X, R) + ARR(i, X + 7)
    
18.         Next
    
19.     Next i
    
20. 
    
21. Sheets("编号").Range("a2").Resize(K, 10) = Application.WorksheetFunction.Transpose(BRR)
    
22. End Sub
    

复制代码

跳转到最佳答案楼层

zgwei050

没有看见附件，不知道数据情况，只能参考一下：

1. Sub niantj()
   
2. Dim d(8) As Object
   
3. Dim i As Long, j As Integer
   
4. Dim LastRow As Long
   
5. Dim arr
   
6. For i = 0 To 8
   
7. Set d(i) = CreateObject("Scripting.dictionary")
   
8. Next i
   
9. With Sheets("录入")
   
10. LastRow = .Range("E" & Rows.Count).End(xlUp).Row
    
11. arr = .Range("A1:Q" & LastRow)
    
12. End With
    
13. ' arr = Sheets("录入").Range("A1").CurrentRegion '如果数据很规范，就用本句代替前面的With...End With
    
14. For i = 1 To UBound(arr, 1)
    
15. d(0)(arr(i, 5)) = d(0)(arr(i, 5)) + arr(i, 8)
    
16. For j = 1 To 8
    
17. d(j)(arr(i, 5)) = d(j)(arr(i, 5)) + arr(i, 9 + j)
    
18. Next j, i
    
19. With Sheets("编号")
    
20. .Cells(2, 1).Resize(d(0).Count, 1) = Application.Transpose(d(0).Keys)
    
21. .Cells(2, 2).Resize(d(0).Count, 1) = Application.Transpose(d(0).Items)
    
22. For j = 1 To 8
    
23. .Cells(2, 2 + j).Resize(d(j).Count, 1) = Application.Transpose(d(j).Items)
    
24. Next j
    
25. End With
    
26. End Sub
    

复制代码

mxg825

一个字典加数组就可以吧！
不用8个字典

mxg825

1. Sub niantj()
   
2. Dim d As New Dictionary
   
3. Dim i As Long, K As Long, R As Long
   
4. Dim ARR, BRR
   
5. 
   
6. ARR = Sheets("录入").UsedRange
   
7.     For i = 1 To UBound(ARR)
   
8.         If d.Exists(ARR(i, 5)) Then
   
9.             R = d(ARR(i, 5))
   
10.             BRR(2, R) = BRR(2, R) + ARR(i, 8)
    
11.             BRR(3, R) = BRR(3, R) + ARR(i, 10)
    
12.             BRR(4, R) = BRR(4, R) + ARR(i, 11)
    
13.             BRR(5, R) = BRR(5, R) + ARR(i, 12)
    
14.             BRR(6, R) = BRR(6, R) + ARR(i, 13)
    
15.             BRR(7, R) = BRR(7, R) + ARR(i, 14)
    
16.             BRR(8, R) = BRR(8, R) + ARR(i, 15)
    
17.             BRR(9, R) = BRR(9, R) + ARR(i, 16)
    
18.             BRR(10, R) = BRR(10, R) + ARR(i, 17)
    
19.         Else
    
20.             K = K + 1
    
21.             d(ARR(i, 5)) = K
    
22.             ReDim Preserve BRR(1 To 10, 1 To K)
    
23.             BRR(1, K) = ARR(i, 5)
    
24.             BRR(2, K) = ARR(i, 8)
    
25.             BRR(3, K) = ARR(i, 10)
    
26.             BRR(4, K) = ARR(i, 11)
    
27.             BRR(5, K) = ARR(i, 12)
    
28.             BRR(6, K) = ARR(i, 13)
    
29.             BRR(7, K) = ARR(i, 14)
    
30.             BRR(8, K) = ARR(i, 15)
    
31.             BRR(9, K) = ARR(i, 16)
    
32.             BRR(10, K) = ARR(i, 17)
    
33.         End If
    
34.     Next i
    
35. 
    
36. Sheets("编号").Range("a2").Resize(K, 10) = Application.WorksheetFunction.Transpose(BRR)
    
37. End Sub

复制代码

mxg825

再优化一次

1. Sub niantj()
   
2. Dim d As New Dictionary
   
3. Dim i As Long, K As Long, R As Long, X As Integer
   
4. Dim ARR, BRR
   
5. 
   
6. ARR = Sheets("录入").UsedRange
   
7.     For i = 1 To UBound(ARR)
   
8.         If Not d.Exists(ARR(i, 5)) Then
   
9.             K = K + 1
   
10.             d(ARR(i, 5)) = K
    
11.             ReDim Preserve BRR(1 To 10, 1 To K)
    
12.             BRR(1, K) = ARR(i, 5)
    
13.         End If
    
14.         R = d(ARR(i, 5))
    
15.         BRR(2, R) = BRR(2, R) + ARR(i, 8)
    
16.         For X = 3 To 10
    
17.            BRR(X, R) = BRR(X, R) + ARR(i, X + 7)
    
18.         Next
    
19.     Next i
    
20. 
    
21. Sheets("编号").Range("a2").Resize(K, 10) = Application.WorksheetFunction.Transpose(BRR)
    
22. End Sub
    

复制代码

liuxingyi88

忠心的谢谢老师！！！辛苦了！！！