按照空行拆分表格并保存为工作簿

Posted 2020-12-21 yukit

Sub 插入()

On Error GoTo errHandler

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
Next
errHandler:

Dim rng As Range ‘分割表格
Range("A1:O" & Range("B65536").End(xlUp).Row).AutoFilter Field:=2, Criteria1:="<>"
For Each rng In Range("A2:O" & Range("B65536").End(xlUp).Row).SpecialCells(xlCellTypeVisible).Areas
Worksheets.Add after:=Worksheets(Worksheets.Count)
rng.Copy ActiveSheet.Range("A1")
Next rng
Range("A1:O" & Range("B65536").End(xlUp).Row).AutoFilter

Dim k As Integer ‘复制表头
For k = 1 To 39
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

Dim x As Integer, sht As Worksheet ‘表格改名
x = 1
For Each sht In Worksheets
If sht.Name <> "汇总" And sht.Name <> "11" Then
sht.Name = Left(sht.Cells(2, 15).Value, Len(sht.Cells(2, 15).Value) - 5)
x = x + 1
End If
Next
On Error Resume Next ‘
Dim FolderPath As String, FolderName As String, BN As String
Dim ReturnValue As Integer

Dim sht As Worksheet
Dim file_name$
For Each sht In Sheets
sht.Copy
file_name = ThisWorkbook.path & "" & sht.Name & ".xlsx"
ActiveWorkbook.SaveAs Filename:=file_name, FileFormat _
:=xlOpenXMLWorkbook, CreateBackup:=False
ActiveWindow.Close
Next
End Sub