vba：EXCEL按照空行分割工作表并保存为独立工作簿后按照指定表名重命名

EXCEL按照空行分割工作表并保存为独立工作簿后按照指定表名重命名代码：

参考原代码：

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 40
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 shtt As Worksheet
Dim file_name$
For Each shtt In Sheets
shtt.Copy
file_name = ThisWorkbook.path & "\" & shtt.Name & ".xlsx"
ActiveWorkbook.SaveAs Filename:=file_name, FileFormat _
:=xlOpenXMLWorkbook, CreateBackup:=False
ActiveWindow.Close
Next
End Sub

修改为：

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 x As Integer, sht As Worksheet '表格改名
x = 1
For Each sht In Worksheets
If sht.Name <> "汇总" And sht.Name <> "11" Then
sht.Name = Worksheets("汇总").Cells(x, 1)
x = x + 1
End If
Next
On Error Resume Next '
Dim FolderPath As String, FolderName As String, BN As String
Dim ReturnValue As Integer


End Sub

直接根据指定的表目录批量修改表名

Sub 改名()
Dim x As Integer, sht As Worksheet '表格改名
x = 1
For Each sht In Worksheets
If sht.Name <> "汇总"  Then
sht.Name = Worksheets("汇总").Cells(x, 1)
x = x + 1
End If
Next
On Error Resume Next '
Dim FolderPath As String, FolderName As String, BN As String
Dim ReturnValue As Integer
End Sub

报错分析处理：

1. 运行到x = x + 1时报错下标溢出，是由于没有“汇总”名称的sheet表导致sht.Name = Worksheets("汇总").Cells(x, 1)这里报错;