[已解决]求助下棋法增加日期识别后的分类汇总代码优化

明日之星 · 发表于 2017-8-22 07:39

本帖最后由明日之星于 2017-8-22 16:52 编辑

大灰狼1976 · 发表于 2017-8-22 09:11

Sub tongji()
Dim brr(1 To 10000, 1 To 3)
Dim r
Dim arr, x As Integer, sr As String, k As Integer
Dim d As New Dictionary
Dim dst As Date, dfh As Date
arr = Sheets("sheet1").Range("c4:m" & Sheets("sheet1").Range("c65536").End(xlUp).Row)
If [k3] <> "" And [l3] <> "" Then
dst = [k3]: dfh = [l3]
For x = 1 To UBound(arr)
If arr(x, 1) >= dst And arr(x, 1) <= dfh Then
sr = arr(x, 9) & "-" & arr(x, 10)
If d.Exists(sr) Then
r = d(sr)
brr(r, 3) = brr(r, 3) + arr(x, 11)
Else
k = k + 1
d(sr) = k
brr(k, 1) = arr(x, 9)
brr(k, 2) = arr(x, 10)
brr(k, 3) = arr(x, 11)
End If
End If
Next x
End If
Sheets("sheet2").Range("b3").Resize(k, 3) = brr
Set Rng = Sheets("sheet2").Range("b2:d60")
Rng.Borders.LineStyle = xlContinuous
Sheets("sheet2").Range("B3:D" & Sheets("sheet2").Range("d65536").End(xlUp).Row).Sort key1:=Sheets("sheet2").Range("D2"), order1:=xlDescending
End Sub

复制代码

明日之星 · 发表于 2017-8-22 09:29

大灰狼1976 发表于 2017-8-22 09:11

代码执行后报错，请大神帮忙诊断是什么原因，谢谢！

大灰狼1976 · 发表于 2017-8-22 09:47

Sub tongji()
Dim brr(1 To 10000, 1 To 3)
Dim r
Dim arr, x As Integer, sr As String, k As Integer
Dim d As New Dictionary
Dim dst As Date, dfh As Date, b As Boolean
arr = Sheets("sheet1").Range("c4:m" & Sheets("sheet1").Range("c65536").End(xlUp).Row)
If [k3] <> "" And [l3] <> "" Then b = True: dst = [k3]: dfh = [l3]
For x = 1 To UBound(arr)
If (arr(x, 1) >= dst And arr(x, 1) <= dfh) Or b = False Then
sr = arr(x, 9) & "-" & arr(x, 10)
If d.Exists(sr) Then
r = d(sr)
brr(r, 3) = brr(r, 3) + arr(x, 11)
Else
k = k + 1
d(sr) = k
brr(k, 1) = arr(x, 9)
brr(k, 2) = arr(x, 10)
brr(k, 3) = arr(x, 11)
End If
End If
Next x
Sheets("sheet2").Range("b3").Resize(k, 3) = brr
Set Rng = Sheets("sheet2").Range("b2:d60")
Rng.Borders.LineStyle = xlContinuous
Sheets("sheet2").Range("B3:D" & Sheets("sheet2").Range("d65536").End(xlUp).Row).Sort key1:=Sheets("sheet2").Range("D2"), order1:=xlDescending
End Sub