Sub 插入()
On Error GoTo errHandler
Cells(2, 13).Select
Dim i As Long '按照标题插入空行
For i = 2 To Range("A1").CurrentRegion.Count - 1
Selection.End(xlDown).Select
Selection.EntireRow.Insert , CopyOrigin:=xlFormatFromLeftOrAbove '插入空行
ActiveCell.Offset(1, 0).Range("A1").Select
Selection.End(xlDown).Select '选择下一个标题
Selection.EntireRow.Insert , CopyOrigin:=xlFormatFromLeftOrAbove
Selection.End(xlDown).Select
Next
errHandler:
Dim rng As Range '分割表格
Range("A1:M" & Range("B65536").End(xlUp).Row).AutoFilter Field:=2, Criteria1:="<>"
For Each rng In Range("A2:M" & Range("B65536").End(xlUp).Row).SpecialCells(xlCellTypeVisible).Areas
Worksheets.Add after:=Worksheets(Worksheets.Count)
rng.Copy ActiveSheet.Range("A1")
Next rng
Range("A1:M" & Range("B65536").End(xlUp).Row).AutoFilter
On Error Resume Next
Dim k As Integer '复制表头
For k = 1 To Sheets.Count - 1
Sheets("汇总").Select
Rows("1:1").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Sheet" & k).Select
Rows("1:1").Select
Selection.Insert Shift:=xlDown
ActiveSheet.Paste
Next
On Error Resume Next '
Dim FolderPath As String, FolderName As String, BN As String
Dim ReturnValue As Integer
Dim file_name$
Dim x As Integer, sht As Worksheet '表格改名
x = 1
For Each sht In Worksheets
If sht.Name <> "汇总" Then
sht.Name = Left(sht.Cells(2, 13).Value, Len(sht.Cells(2, 13).Value) - 5) '表格改名
sht.Copy '工作簿分割
file_name = ThisWorkbook.Path & "" & sht.Name & ".xlsx"
ActiveWorkbook.SaveAs Filename:=file_name, FileFormat _
:=xlOpenXMLWorkbook, CreateBackup:=False
ActiveWindow.Close
x = x + 1
End If
Next
End Sub