|
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用 · 内置多项VBA编程加强工具 ★ 免费下载 ★ ★ 使用手册★
- Sub test()
- Dim r%, i%
- Dim arr, brr
- Dim d As Object
- Set d = CreateObject("scripting.dictionary")
- With Worksheets("明细表")
- r = .Cells(.Rows.Count, 3).End(xlUp).Row
- arr = .Range("a6:h" & r)
- End With
- m = 0
- For i = 1 To UBound(arr)
- If Len(arr(i, 2)) <> 0 Then
- bm = arr(i, 2)
- End If
- If Not d.exists(bm) Then
- m = m + 1
- ReDim brr(1 To 7)
- brr(1) = m
- brr(2) = bm
- Else
- brr = d(bm)
- End If
- For j = 4 To UBound(arr, 2)
- brr(j - 1) = brr(j - 1) + arr(i, j)
- Next
- d(bm) = brr
- Next
- With Worksheets("合计表")
- .UsedRange.Offset(5, 0).Clear
- With .Range("a6").Resize(d.Count, UBound(brr))
- .Value = Application.Transpose(Application.Transpose(d.items))
- .Borders.LineStyle = xlContinuous
- End With
- .Rows(6).Resize(d.Count).RowHeight = 20
- With .UsedRange
- .HorizontalAlignment = xlCenter
- .VerticalAlignment = xlCenter
- End With
-
- End With
- End Sub
复制代码 |
|