根据指定行拆分EXCEL表格

Sub Delete_extra_tables()
'1、首先删除多余的数据表
Dim i As Integer

Dim sht As Worksheet

Application.DisplayAlerts = False

If Worksheets.Count > 1 Then
   For Each sht In Worksheets
        If sht.Name <> "数据" Then
            sht.Delete
        End If
    Next
End If

Application.DisplayAlerts = True

Sheets("数据").Select
End Sub

Sub create_sht(l As Integer)
'2、根据需要拆分的列创建不同的sheet页
Dim i As Integer
Dim sht As Worksheet



irows = Sheet1.Range("a100000").End(xlUp).Row

For i = 2 To irows
    k = 0
    For Each sht In Worksheets
        If sht.Name = Sheet1.Cells(i, l) Then
            k = 1
        End If
    Next
    
    If k = 0 Then
        Worksheets.Add after:=Sheets(Sheets.Count)
        Sheets(Sheets.Count).Name = Sheet1.Cells(i, l)
    End If
        
Next
Sheet1.Select

End Sub

Sub copy_data(l As Integer)
'3、复制出对应的数据

Dim i As Integer

irows = Sheet1.Range("a100000").End(xlUp).Row

For i = 2 To Sheets.Count
    'Sheet1.Range("a1:f" & irows).AutoFilter
    Sheet1.Range("a1:f" & irows).AutoFilter Field:=l, Criteria1:=Sheets(i).Name
    Sheet1.Range("a1:f" & irows).Copy Sheets(i).Range("a1")

Next

Sheet1.Range("a1:f" & irows).AutoFilter

End Sub

Sub chaifen()
'4、将拆分出来的sheet分到不同的workbook里面
Dim sht As Worksheet

If Sheets.Count > 1 Then
    For Each sht In Worksheets
        If sht.Name <> "数据" Then
            sht.Copy
            ActiveWorkbook.SaveAs Filename:="D:\backup\vba_data\" & sht.Name & ".xlsx"
            ActiveWorkbook.Close
        End If
        
    Next
End If

MsgBox "Done!"

End Sub

Sub check_sheet_name(chk As Integer)
'确保要拆分的数据表叫做数据；
'并且要拆分的数据表为当前选择的表
Dim str As String
k = 0
str = ActiveSheet.Name

If str <> "数据" Then
    MsgBox "请选择要拆分的数据表，并将sheet命名为数据"
    chk = 1
    Exit Sub
End If
             
    
End Sub

Sub split_tab_accord_col()

Dim chkd As Integer

chkd = 0

Call check_sheet_name(chkd)

If chkd = 0 Then

    Dim l As Integer
    
    l = Val(InputBox("请输入需要拆分的列:"))
    
    Call Delete_extra_tables
    Call create_sht(l)
    Call copy_data(l)
    
    MsgBox ("处理完毕")
    
    Sheet1.Select

End If

End Sub