|
|
Sub 分表()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim ar As Variant
Set sht = Sheets("基础信息")
Set shw = Sheets("收方表")
Dim br()
With sht
r = .Cells(Rows.Count, 1).End(xlUp).Row
If r < 3 Then MsgBox "基础信息为空！": End
ar = .Range("a1:ac" & r)
End With
For Each sh In Sheets
If sh.Index > 2 Then
sh.Delete
End If
Next sh
For i = 4 To UBound(ar)
If ar(i, 1) <> "" Then
n = 0
ReDim br(1 To UBound(ar, 2) * 2, 1 To 7)
For j = 2 To UBound(ar, 2)
If ar(1, j) <> "" Then
ls = sht.Cells(1, j).MergeArea.Columns.Count
m = 0
For s = j To j + ls - 1
If ar(i, s) <> "" Then
If ar(i, s) > 0 Then
n = n + 1
br(n, 2) = ar(1, j)
Exit For
End If
End If
Next s
For s = j To j + ls - 1
If ar(i, s) <> "" Then
If ar(i, s) > 0 Then
n = n + 1
m = m + 1
br(n, 1) = m
br(n, 2) = ar(2, s)
br(n, 3) = ar(3, s)
br(n, 7) = ar(i, s)
End If
End If
Next s
End If
Next j
If n > 0 Then
shw.Copy after:=Sheets(Sheets.Count)
With ActiveSheet
.Name = ar(i, 1)
.[j3] = ar(i, 1)
.[a6].Resize(n, UBound(br, 2)) = br
If n < 58 Then .Rows(n + 6 & ":63").Delete
End With
End If
End If
Next i
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub
|
评分
-
2
查看全部评分
-
|
/1 
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2024-3-17 00:23
