|
Sub 拆分()
Application.ScreenUpdating = False
Dim ar As Variant, cr As Variant
Dim i As Long, r As Long, rs As Long
Dim br()
Dim d As Object
Set d = CreateObject("scripting.dictionary")
Application.DisplayAlerts = False
For Each sh In Sheets
If sh.Index > 4 Then
sh.Delete
End If
Next sh
Application.DisplayAlerts = True
With Sheet1
r = .Cells(Rows.Count, 1).End(xlUp).Row
ar = .Range("a2:i" & r)
End With
For i = 2 To UBound(ar)
If ar(i, 1) <> "" Then
zd = ar(i, 1) & ar(i, 2)
If d(zd) = "" Then
d(zd) = i
Else
d(zd) = d(zd) & "|" & i
End If
End If
Next i
For Each k In d.keys
n = 0
ReDim br(1 To UBound(ar), 1 To UBound(ar, 2))
rr = Split(d(k), "|")
For i = 0 To UBound(rr)
x = rr(i)
n = n + 1
For j = 1 To UBound(ar, 2)
br(n, j) = ar(x, j)
Next j
Next i
Sheets("模板").Copy after:=Sheets(Sheets.Count)
With ActiveSheet
.Name = k
.[f1] = Sheet1.[f1]
.[a3].Resize(n, UBound(br, 2)) = br
.Cells(n + 5, 4) = "合计"
.Cells(n + 5, 7) = Application.Sum(Application.Index(br, 0, 7))
.Cells(n + 5, 9) = Application.Sum(Application.Index(br, 0, 9))
.[a3].Resize(n + 3, UBound(br, 2)).Borders.LineStyle = 1
End With
Next k
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub
|
|