[已解决]用字典方法汇总vba代码修改

sgyzzz · 发表于 2013-12-5 13:53

我的代码运行时错误“1004”，为什么呢？

台账.rar (171.28 KB, 下载次数: 9)

兰色幻想 · 发表于 2013-12-5 14:08

本帖最后由兰色幻想于 2013-12-5 14:10 编辑

i=671 时 arr(i, 13) 和 arr(i, 14) 结果都是空值，你把光标放在上面就能看到值。所以造成d2()也出错

zjdh · 发表于 2013-12-5 14:19

本帖最后由 zjdh 于 2013-12-5 14:20 编辑

台账.rar (165.8 KB, 下载次数: 42)

zjdh · 发表于 2013-12-5 14:22

根源在你这句上
arr = .UsedRange

sgyzzz · 发表于 2013-12-5 15:06

zjdh 发表于 2013-12-5 14:22
根源在你这句上
arr = .UsedRange

谢谢你的帮助！现在找到了出错的原因了。本代码运行速度较慢，我想把运算结果放在crr这个数组里，以提高运算速度，但没弄成功，你能帮我修改一下代码吗？

sgyzzz · 发表于 2013-12-5 19:10

是arr = .UsedRange这句代码有问题，谢谢兰版主，我用的是你讲的下棋的方法汇总，我想结合数组提高运算速度，谁有时间帮忙修改一下。

sgyzzz · 发表于 2013-12-6 09:18

Sub 总指标额度()
Dim d1 As New Dictionary
Dim d2 As New Dictionary
Dim i As Long
Dim m As Long
Dim x As Long
Dim arr, brr, crr()
Dim t
t = Timer
Range("a6:aj65536").ClearContents
brr = Range("b4:aj5")
For m = 1 To 35
If brr(1, m) = "" Then
brr(1, m) = brr(1, m - 1)
End If
If d2.Exists(brr(1, m) & brr(2, m)) = False Then
d2(brr(1, m) & brr(2, m)) = d2.Count + 2
End If
Next m
With Sheets("数据录入")
arr = .Range("A6:O" & .Range("B65536").End(xlUp).Row).Value
End With
For x = 1 To UBound(arr)
If arr(x, 2) <> "" Then
If Not d1.Exists(arr(x, 2)) Then
i = i + 1
d1(arr(x, 2)) = i
ReDim Preserve crr(1 To 36, 0 To i)
crr(1, i) = arr(x, 2)
End If
crr(2, d1(arr(x, 2))) = crr(2, d1(arr(x, 2))) + arr(x, 10)
If arr(x, 13) = "年初预算" Then
crr(8, d1(arr(x, 2))) = crr(8, d1(arr(x, 2))) + arr(x, 10)
ElseIf arr(x, 13) = "上年结转" Then
crr(11, d1(arr(x, 2))) = crr(11, d1(arr(x, 2))) + arr(x, 10)
ElseIf arr(x, 13) = "中途追加" Then
crr(36, d1(arr(x, 2))) = crr(36, d1(arr(x, 2))) + arr(x, 10)
End If
crr(d2(arr(x, 13) & arr(x, 14)), d1(arr(x, 2))) = crr(d2(arr(x, 13) & arr(x, 14)), d1(arr(x, 2))) + arr(x, 10)
End If
Next x
i = i + 1
ReDim Preserve crr(1 To 36, 0 To i)
crr(1, 0) = "合计"
For x = 2 To 36
For y = 1 To i
crr(x, 0) = crr(x, 0) + crr(x, y)
Next y, x
With Sheets("总指标额度")
.Range("A6:AJ65536").ClearContents
.Range("A6:AJ65536").Borders.LineStyle = 0
.Range("A6").Resize(UBound(crr, 2), UBound(crr)) = Application.Transpose(crr)
.Range("A6").Resize(UBound(crr, 2), UBound(crr)).Borders.LineStyle = 1
End With
' Cells(6, 1) = "合计"
' For x = 2 To 36
' For y = 7 To i + 7
'Cells(6, x) = Cells(6, x) + Cells(y, x)
' Next y, x
MsgBox "苏广余提示，汇总结束，用时" & Timer - t & "秒"
End Sub

复制代码

自己弄好了

zjdh · 发表于 2013-12-6 09:35

正想动手帮你，你已经自己搞定了，自己动手丰衣足食！

sgyzzz · 发表于 2013-12-7 09:07

zjdh 发表于 2013-12-6 09:35
正想动手帮你，你已经自己搞定了，自己动手丰衣足食！

谢谢你的帮助！

ZZCUEEI · 发表于 2013-12-16 12:31

		自动登录	找回密码
密码			注册