|
|
Sub 凭证()
Dim ar As Variant
Dim rr()
With Sheets("分录")
r = .Cells(Rows.Count, 3).End(xlUp).Row
ar = .Range("a1:e" & r)
End With
ReDim rr(1 To UBound(ar))
For i = 2 To UBound(ar)
If ar(i, 1) <> Empty Then
n = n + 1
rr(n) = i
End If
Next i
If n = "" Then MsgBox "分录A列缺少序号标识符！": End
With Sheets("凭证")
rs = .Cells(Rows.Count, 1).End(xlUp).Row
.Range("a4:e8") = Empty
If rs >= 10 Then .Rows("10:" & rs).Delete
m = 10
For i = 1 To n - 1
.Rows("1:9").Copy .Cells(m, 1)
m = m + 9
Next i
n = n + 1
rr(n) = r + 1
m = 2
For i = 1 To n - 1
ks = rr(i)
js = rr(i + 1) - 1
.Cells(m, 5) = ar(ks, 1)
.Cells(m + 2, 1) = ar(ks, 2)
xh = m + 1
For s = ks To js
xh = xh + 1
.Cells(xh, 2) = ar(s, 3)
.Cells(xh, 4) = ar(s, 4)
.Cells(xh, 5) = ar(s, 5)
Next s
m = m + 9
Next i
End With
MsgBox "ok!"
End Sub
|
|
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2024-2-2 20:20
楼主
谢谢
