|
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用 · 内置多项VBA编程加强工具 ★ 免费下载 ★ ★ 使用手册★
Sub sss()
Dim arr, brr
Dim i%, j%, lr%
Application.ScreenUpdating = False: Application.DisplayAlerts = False
With Sheets("统计")
.Activate
.[a4:i1000].ClearContents: .[a4:i1000].Borders.LineStyle = xlNone
.Cells.UnMerge: .[a1:i1].Merge
.[b2] = .[m2]
End With
arr = Sheets("明细").UsedRange
ReDim brr(1 To UBound(arr), 1 To 9)
m = 0
For i = 2 To UBound(arr)
If arr(i, 2) = [m2] Then
m = m + 1
brr(m, 1) = m
For n = 2 To 5
brr(m, n) = arr(i, n + 1)
Next
brr(m, 6) = arr(i, 8)
brr(m, 9) = arr(i, 9)
End If
Next
[a4].Resize(UBound(brr), UBound(brr, 2)) = brr
lr = Cells(Rows.Count, 1).End(3).Row
i = 4
For j = i + 1 To lr
If Range("c" & j) <> "" Then
Range("b" & i & ":" & "b" & j - 1).Merge: Range("c" & i & ":" & "c" & j - 1).Merge
Range("g" & i & ":" & "g" & j - 1).Merge: Range("g" & i) = WorksheetFunction.Sum(Range("f" & i & ":" & "f" & j - 1))
Range("h" & i & ":" & "h" & j - 1).Merge: Range("h" & i) = Range("g" & i) / Range("c" & i)
i = j
End If
Next
Cells(lr + 1, 1) = "合计:"
arr = Array(3, 5, 6, 7)
For i = 0 To 3
Cells(lr + 1, arr(i)) = WorksheetFunction.Sum(Range(Cells(4, arr(i)), Cells(lr, arr(i))))
Next
Range("a3:i" & lr + 1).Borders.LineStyle = xlContinuous
Application.ScreenUpdating = True: Application.DisplayAlerts = True
MsgBox "完成"
End Sub
|
|