|
楼主 |
发表于 2017-8-12 00:02
|
显示全部楼层
自己终于搞定了,采用辅助数据区域,根据月份数字进行排序得到想要的结果。代码如下:
Sub tj() '字典法
Dim m, n, k
Set d = CreateObject("scripting.dictionary")
Set d1 = CreateObject("scripting.dictionary")
Set d2 = CreateObject("scripting.dictionary")
Set d3 = CreateObject("scripting.dictionary")
Set d4 = CreateObject("scripting.dictionary")
arr = Sheet3.UsedRange
brr = Sheet4.Range("A3:A14")
Dim c(1 To 12), crr(1 To 1000, 1 To 2)
If UBound(arr) = 2 Then MsgBox "没有数据!请更新数据。": End
t = Timer()
Application.ScreenUpdating = False
Sheet4.Range("B3:E14").ClearContents
Sheet4.Range("H3:L14").ClearContents
m = 0
For j = 3 To r
If Month(arr(j, 3)) > 0 Then
m = m + 1
crr(m, 1) = Month(arr(j, 3))
End If
Next
Sheet3.Range("P3").Resize(UBound(crr), 1) = crr
For i = 3 To UBound(arr)
d(Month(arr(i, 3))) = ""
Next i
For i = 1 To Month(arr(UBound(arr), 3))
If Not d.exists(i) Then n = n + 1: c(n) = i: Sheet4.Range("H" & 2 + n) = c(n): d1(i) = 0: d2(i) = 0: d3(i) = 0: d4(i) = 0
Next i
For j = 3 To UBound(arr)
If d.exists(Month(arr(j, 3))) Then
d1(Month(arr(j, 3))) = d1(Month(arr(j, 3))) + arr(j, 7)
d2(Month(arr(j, 3))) = d2(Month(arr(j, 3))) + arr(j, 8)
d3(Month(arr(j, 3))) = d3(Month(arr(j, 3))) + arr(j, 9)
d4(Month(arr(j, 3))) = d4(Month(arr(j, 3))) + arr(j, 10)
End If
Next j
'添加辅助数据
Sheet4.Range("H" & 3 + n).Resize(d.Count) = WorksheetFunction.Transpose(d.keys)
Sheet4.Range("I3").Resize(d1.Count) = WorksheetFunction.Transpose(d1.Items)
Sheet4.Range("J3").Resize(d2.Count) = WorksheetFunction.Transpose(d2.Items)
Sheet4.Range("K3").Resize(d3.Count) = WorksheetFunction.Transpose(d3.Items)
Sheet4.Range("L3").Resize(d4.Count) = WorksheetFunction.Transpose(d4.Items)
'根据月份排序
Sheet4.Range("H3:L14").Select
Selection.Sort Key1:=Range("H3:H9"), Order1:=xlAscending, Header:= _
xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
SortMethod:=xlPinYin, DataOption1:=xlSortNormal
Sheet4.Range("I3:L14").Copy
Sheet4.Range("B3").PasteSpecial xlPasteValues
Sheet4.Range("H3:L14").ClearContents
Application.ScreenUpdating = True
MsgBox "用时" & Format(Timer - t, "0.000秒,")
Set d = Nothing: Set d1 = Nothing: Set d2 = Nothing: Set d3 = Nothing: Set d4 = Nothing:
End Sub
小弟刚接触字典,希望各位大大有空指点指点,优化一下,不胜感谢! |
|