[已解决]帮看下代码哪有问题

lgzxmlg

帮看下代码哪有问题，第三项为什么计算错误？ Book1.zip (10.08 KB, 下载次数: 6)

2011-11-18 21:39 上传

点击文件名下载附件


With Sheets("高炉铁水整理")表中C2:C 为日期，E2:E为数据，求每日"G2:G"和"J2:J"数据大于35对应的E列数据和。
将数据填入Sheets("信息表")表中
Sub test()
Dim arr
Dim i As Integer
'Dim Dic As New Dictionary
'Dim Did As New Dictionary
Dim arrData As Variant
Set Dic = CreateObject("Scripting.Dictionary")
Set Did = CreateObject("Scripting.Dictionary")
Set Die = CreateObject("Scripting.Dictionary")
    Dim T As Date, T1 As Date
   
     T = Sheets("信息表").Range("h2")  '开始日期
    T1 = Sheets("信息表").Range("j2")    '结束日期
With Sheets("高炉铁水整理")
    arr = .Range("c2:k" & .[c65536].End(3).Row)
End With
For i = 1 To UBound(arr)
    If arr(i, 1) >= T And arr(i, 1) <= T1 Then
        Dic(arr(i, 1)) = Dic(arr(i, 1)) + arr(i, 3)
        If arr(i, 1) >= T And arr(i, 1) <= T1 And arr(i, 8) > 35 Then
        Did(arr(i, 1)) = Did(arr(i, 1)) + arr(i, 3)
        If arr(i, 1) >= T And arr(i, 1) <= T1 And arr(i, 5) > 35 Then
        Die(arr(i, 1)) = Die(arr(i, 1)) + arr(i, 3)
        Else
            Did(arr(i, 1)) = Did(arr(i, 1))
        End If
    End If
     End If
Next
With Sheets("信息表")
     .[k5:s65536].ClearContents
    .[k5].Resize(Dic.Count, 1) = Application.Transpose(Dic.Keys)
    .[l5].Resize(Dic.Count, 1) = Application.Transpose(Dic.Items)
    .[m5].Resize(Did.Count, 1) = Application.Transpose(Did.Items)
    .[n5].Resize(Die.Count, 1) = Application.Transpose(Die.Items)
End With
Set Dic = Nothing
Set Did = Nothing
Set Die = Nothing
End Sub

最佳答案

月排行榜 / 总排行榜

mxg825

2011-11-18 22:07

1. Sub testMXG825()
   
2. Dim arr, brr()
   
3. Dim i As Integer, K As Integer, Icol As Integer
   
4. Dim arrData As Variant
   
5. Set D = CreateObject("Scripting.Dictionary")
   
6. Dim T As Date, T1 As Date
   
7. T = Sheets("信息表").Range("h2") '开始日期
   
8. T1 = Sheets("信息表").Range("j2") '结束日期
   
9. With Sheets("高炉铁水整理")
   
10. arr = .Range("c2:k" & .[c65536].End(3).Row)
    
11. End With
    
12. For i = 1 To UBound(arr)
    
13. If arr(i, 1) >= T And arr(i, 1) <= T1 Then
    
14. If D.Exists(arr(i, 1)) Then
    
15. Icol = D(arr(i, 1))
    
16. brr(2, Icol) = brr(2, Icol) + arr(i, 3)
    
17. If arr(i, 8) > 35 Then brr(3, Icol) = brr(3, Icol) + arr(i, 3)
    
18. If arr(i, 5) > 35 Then brr(4, Icol) = brr(4, Icol) + arr(i, 3)
    
19. Else
    
20. K = K + 1
    
21. D(arr(i, 1)) = K
    
22. ReDim Preserve brr(1 To 4, 1 To K)
    
23. brr(1, K) = arr(i, 1)
    
24. brr(2, K) = arr(i, 3)
    
25. If arr(i, 8) > 35 Then brr(3, K) = arr(i, 3)
    
26. If arr(i, 5) > 35 Then brr(4, K) = arr(i, 3)
    
27. End If
    
28. End If
    
29. Next
    
30. With Sheets("信息表")
    
31. .[k5:s65536].ClearContents
    
32. .[k5].Resize(K, 4) = Application.Transpose(brr)
    
33. End With
    
34. Set D = Nothing
    
35. End Sub

复制代码

跳转到最佳答案楼层

lgzxmlg

请帮我看下，在线等！！

lgzxmlg

在线的朋友帮看下

mxg825

没说明！猜不出来！
应该就是IF 语句 逻辑不对！

mxg825

我猜一下
Sub test()
Dim arr, brr
Dim i As Integer, K As Integer
Dim arrData As Variant
Set D = CreateObject("Scripting.Dictionary")
Dim T As Date, T1 As Date
    T = Sheets("信息表").Range("h2")  '开始日期
    T1 = Sheets("信息表").Range("j2")    '结束日期
With Sheets("高炉铁水整理")
    arr = .Range("c2:k" & .[c65536].End(3).Row)
End With
brr(1 To UBound(arr), 1 To 4)
For i = 1 To UBound(arr)
    If arr(i, 1) >= T And arr(i, 1) <= T1 Then
        If D.Exists(arr(X, 1)) Then
           ICOL = D(arr(X, 1))
           brr(2, ICOL) = brr(2, ICOL) + arr(i, 3)
           If arr(i, 8) > 35 Then brr(3, ICOL) = brr(3, ICOL) + arr(i, 3)
           If arr(i, 5) > 35 Then brr(4, ICOL) = brr(4, ICOL) + arr(i, 3)
        Else
            K = K + 1
            D(arr(i, 1)) = K
            ReDim Preserve brr(1 To 4, 1 To K)
            brr(1, K) = arr(i, 1)
            brr(2, K) = arr(i, 3)
            If arr(i, 8) > 35 Then brr(3, K) = arr(i, 3)
            If arr(i, 5) > 35 Then brr(4, K) = arr(i, 3)
        End If
    End If
Next
With Sheets("信息表")
     .[k5:s65536].ClearContents
     .[k5].Resize(K, 4) = Application.Transpose(brr)
End With
Set D = Nothing
End Sub

lgzxmlg

mxg825 发表于 2011-11-18 20:50
我猜一下
Sub test()
Dim arr, brr

brr(1 To UBound(arr), 1 To 4)
提示无效

lgzxmlg

我上传了附件，再帮看下，谢谢

mxg825

删掉这句、忘了删掉

mxg825

1. Sub testMXG825()
   
2. Dim arr, brr()
   
3. Dim i As Integer, K As Integer, Icol As Integer
   
4. Dim arrData As Variant
   
5. Set D = CreateObject("Scripting.Dictionary")
   
6. Dim T As Date, T1 As Date
   
7. T = Sheets("信息表").Range("h2") '开始日期
   
8. T1 = Sheets("信息表").Range("j2") '结束日期
   
9. With Sheets("高炉铁水整理")
   
10. arr = .Range("c2:k" & .[c65536].End(3).Row)
    
11. End With
    
12. For i = 1 To UBound(arr)
    
13. If arr(i, 1) >= T And arr(i, 1) <= T1 Then
    
14. If D.Exists(arr(i, 1)) Then
    
15. Icol = D(arr(i, 1))
    
16. brr(2, Icol) = brr(2, Icol) + arr(i, 3)
    
17. If arr(i, 8) > 35 Then brr(3, Icol) = brr(3, Icol) + arr(i, 3)
    
18. If arr(i, 5) > 35 Then brr(4, Icol) = brr(4, Icol) + arr(i, 3)
    
19. Else
    
20. K = K + 1
    
21. D(arr(i, 1)) = K
    
22. ReDim Preserve brr(1 To 4, 1 To K)
    
23. brr(1, K) = arr(i, 1)
    
24. brr(2, K) = arr(i, 3)
    
25. If arr(i, 8) > 35 Then brr(3, K) = arr(i, 3)
    
26. If arr(i, 5) > 35 Then brr(4, K) = arr(i, 3)
    
27. End If
    
28. End If
    
29. Next
    
30. With Sheets("信息表")
    
31. .[k5:s65536].ClearContents
    
32. .[k5].Resize(K, 4) = Application.Transpose(brr)
    
33. End With
    
34. Set D = Nothing
    
35. End Sub

复制代码

lgzxmlg

mxg825 发表于 2011-11-18 21:52
删掉这句、忘了删掉

删掉后，提示政界越界。不知什么原因