Sub Macro1()
Dim arr, brr(), crr(1 To 30, 3 To 8), d As Object, k, t, a, i&, j&, m&, l&
Dim w As WorksheetFunction, sh As Worksheet, wb As Workbook
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set d = CreateObject("scripting.dictionary")
arr = [a1].CurrentRegion
For i = 2 To UBound(arr)
s = arr(i, 2) & "_" & arr(i, 3)
d(s) = d(s) & "," & i
Next
k = d.Keys
t = d.Items
Set sh = Sheets("模板")
Set w = WorksheetFunction
For i = 0 To d.Count - 1
a = Split(t(i), ",")
ReDim brr(1 To w.RoundUp(UBound(a) / 30, 0) * 30, 3 To 8)
For j = 1 To UBound(a)
brr(j, 3) = j
For l = 4 To 8
brr(j, l) = arr(a(j), l)
Next
Next
m = j - 1
For j = w.RoundUp(m / 30, 0) * 30 To 1 Step -30
f = j - 29
If wb Is Nothing Then
sh.Copy
Set wb = ActiveWorkbook
Else
sh.Copy Before:=wb.Sheets(1)
End If
With ActiveSheet
.[A2] = .[A2] & Split(k(i), "_")(0)
.[A3] = .[A3] & Split(k(i), "_")(1)
If m <= 30 Then
.[a5].Resize(m, 6) = brr
.Name = k(i)
Else
Erase crr
n = 0
For v = f To f + 29
n = n + 1
For l = 3 To 8
crr(n, l) = brr(v, l)
Next
Next
.[a5].Resize(30, 6) = crr
End If
End With
Next
If m > 30 Then
For j = 1 To wb.Sheets.Count
wb.Sheets(j).Name = k(i) & j
Next
End If
wb.Close True, Filename:=ThisWorkbook.Path & "\" & k(i) & ".xls"
Set wb = Nothing
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "ok"
End Sub