|
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件 ★ 免费下载 ★ ★ 使用帮助★
- Sub test()
- Dim r%, i%
- Dim rng As Range
- Dim ws As Worksheet
- Dim arr, brr, zrr(), hg(1 To 4) As Double
- Application.ScreenUpdating = False
- Application.DisplayAlerts = False
- Set ws = Worksheets("工资表")
- With ws
- Set rng = .Range("a1:w3")
- For i = 1 To 4
- hg(i) = .Rows(i).RowHeight
- Next
- r = .Cells(.Rows.Count, 1).End(xlUp).Row
- arr = .Range("c1:c" & r)
- bm = ""
- For i = 4 To UBound(arr)
- If arr(i, 1) <> bm Then
- m = m + 1
- ReDim Preserve zrr(1 To 2, 1 To m)
- zrr(1, m) = i
- zrr(2, m) = i
- bm = arr(i, 1)
- Else
- zrr(2, m) = i
- End If
- Next
- End With
- With Worksheets("结果")
- .Cells.Clear
- m = 1
- For k = 1 To UBound(zrr, 2)
- For i = zrr(1, k) To zrr(2, k) Step 33
- rng.Copy .Cells(m, 1)
- With .Cells(m + 1, 1).Resize(1, 2)
- .Value = Array("部门", arr(i, 1))
- With .Font
- .Name = "宋体"
- .Size = 12
- End With
- End With
- ws.Cells(i, 1).Resize(IIf(i + 32 <= zrr(2, k), 33, (zrr(2, k) - zrr(1, k) + 1) Mod 33), 23).Copy .Cells(m + 3, 1)
- .Cells(m + 36, 2) = "小计"
- With .Cells(m + 36, 4).Resize(1, 20)
- .FormulaR1C1 = "=SUM(R" & m + 3 & "C:R[-1]C)"
- .ShrinkToFit = True
- End With
- With .Cells(m + 2, 1).Resize(35, 23)
- .Borders.LineStyle = xlContinuous
- With .Font
- .Size = 9
- End With
- End With
- .Cells(m + 37, 2) = "制表:"
- .Cells(m + 37, 3) = "李会圆"
- .Cells(m + 37, 8) = "审核:"
- .Cells(m + 37, 9) = "马东海"
- For j = 1 To 3
- .Rows(m + j - 1).RowHeight = hg(j)
- Next
- .Rows(m + 3).Resize(33).RowHeight = hg(4)
- m = m + 38
- Next
- Next
- With .UsedRange
- .HorizontalAlignment = xlCenter
- .VerticalAlignment = xlCenter
- End With
- End With
- End Sub
复制代码 |
|