参与一下。。。- Sub ykcbf() '//2024.5.13
- Dim arr, brr, d, s
- Application.ScreenUpdating = False
- Application.DisplayAlerts = False
- Set d = CreateObject("scripting.dictionary")
- ReDim brr(1 To 100000, 1 To 100)
- m = 1: n = 3
- On Error Resume Next
- With Sheets("数据")
- r = .Cells(Rows.Count, 1).End(3).Row
- arr = .[a1].Resize(r, 5)
- brr(1, 1) = arr(6, 2)
- brr(1, 2) = arr(6, 3)
- brr(1, 3) = arr(6, 4)
- End With
- For i = 7 To UBound(arr)
- If arr(i, 1) <> Empty Then
- s = arr(i, 2) & "|" & arr(i, 3) & "|" & arr(i, 4)
- If Not d.exists(s) Then
- m = m + 1
- d(s) = m
- brr(m, 1) = arr(i, 2)
- brr(m, 2) = arr(i, 3)
- brr(m, 3) = arr(i, 4)
- End If
- r = d(arr(i, 2) & "|" & arr(i, 3) & "|" & arr(i, 4))
- s = Format(arr(i, 1), "yyyy-mm")
- If Not d.exists(s) Then
- n = n + 1
- d(s) = n
- brr(1, n) = s
- End If
- c = d(Format(arr(i, 1), "yyyy-mm"))
- brr(r, c) = brr(r, c) + arr(i, 5)
- End If
- Next
- With Sheets("统计")
- .UsedRange.Clear
- .[a1].Resize(m, n) = brr
- .[a1].Resize(1, n).Interior.Color = 49407
- .[a2].Resize(m - 1, 1).Interior.Color = 5296274
- ActiveWindow.DisplayZeros = False
- Set Rng = .[a1].Resize(m, n)
- With Rng
- .Borders.LineStyle = 1
- .HorizontalAlignment = xlCenter
- .VerticalAlignment = xlCenter
- With .Font
- .Name = "微软雅黑"
- .Size = 11
- End With
- End With
- .[a2].Resize(m - 1, n).Sort .[a2], 1
- End With
- Set d = Nothing
- Application.ScreenUpdating = True
- MsgBox "OK!"
- End Sub
复制代码
|