|
楼主 |
发表于 2019-8-12 10:50
|
显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件 ★ 免费下载 ★ ★ 使用帮助★
sub 汇总()
Dim r%, i%, m%
Dim arr, brr, zrr()
m = 0
With Worksheets("2019")'需汇总的工作表
r = .UsedRange.Find(what:="*", LookIn:=xlValues, lookat:=xlWhole, searchorder:=xlByRows, searchdirection:=xlPrevious).Row
arr = .Range("a3:u" & r)'工作表区域
End With
For i = 1 To UBound(arr)
If arr(i, 1) = "待检品往来帐" Then
m = m + 1
ReDim Preserve zrr(1 To 5, 1 To m)
zrr(1, m) = i
zrr(2, m) = i
Else
zrr(2, m) = i
End If
Next
ReDim brr(1 To UBound(arr), 1 To 30)
m = 0
For k = 1 To UBound(zrr, 2)
For i = zrr(1, k) + 3 To zrr(2, k)
If Len(arr(i, 6)) <> 0 Then
m = m + 1
brr(m, 1) = m
brr(m, 2) = arr(zrr(1, k) + 1, 2)
For j = 2 To UBound(arr, 2)
brr(m, j + 1) = arr(i, j)
Next
End If
Next
Next
With Worksheets("201908")'汇总到存放的工作表
.UsedRange.Offset(3, 0).Clear '区域偏移
.Range("a2").Resize(m, UBound(brr, 2)) = brr
r = m + 3
With .Range("a3:u" & r)
.Borders.LineStyle = xlContinuous
With .Font
.Size = 9
End With
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
MsgBox "汇总已完成"
End With
End With
End Sub
|
|