Option Explicit

Public Sub 分表循环()
    
    '注意执行此宏会修改当前工作表，一定要在副本中运行
    '执行此宏前一定要选中用作分表的关键字的整列
    '工作表当中必须只有一个区域，一个Sheet中有多个区域是不行的
    '拆分的工作表在当前工作簿文件夹下
    '列中的关键字不要跟总表名重复
    
    Dim isok As String
    
    isok = MsgBox("该操作会删除该工作表，是否继续", vbYesNo)
    
    If isok <> vbYes Then
        Exit Sub
    End If
    
    Dim path As String
    
    Dim fullPath As String
    
    Dim columnIndex As Long
    
    Dim keyAddress As String
    
    Dim title As String
    
    title = ActiveWindow.Caption
    
    path = Application.ActiveWorkbook.path
    
    fullPath = Application.ActiveWorkbook.FullName
    
    keyAddress = Selection.item(2).address
        
    columnIndex = ActiveSheet.range(keyAddress).column
     
    While IsEmpty(ActiveSheet.range(keyAddress)) = False
        ' 因为表格会被代码删除更新所以锚定单元格的值必须每次重新获取
        
        Call 另存为新表然后删除不需要的(columnIndex, path, ActiveSheet.range(keyAddress).Value2, fullPath, title)
        Call 删除已经移除的(columnIndex, ActiveSheet.range(keyAddress).Value2)
    Wend
    
    MsgBox "拆分完成"
End Sub




Private Sub 删除已经移除的(columnIndex As Long, key As String)
    ActiveSheet.Cells.AutoFilter Field:=columnIndex, Criteria1:=key
    
    Call 删除所有可见行除了标题
    
    ActiveWorkbook.Save
End Sub

Private Sub 删除所有可见行除了标题()
     ActiveSheet.Cells.Rows("2:" & ActiveSheet.Rows.Count).SpecialCells(xlCellTypeVisible).Delete
End Sub

Private Sub 另存为新表然后删除不需要的(columnIndex As Long, path As String, newName As String, fullPath As String, title As String)
    
    Dim newPath As String
    
    newPath = path & "\" & newName & ".xlsx"
    
    
    ActiveWorkbook.SaveAs Filename:= _
        newPath, FileFormat:= _
        xlOpenXMLWorkbook, CreateBackup:=False
     
    ActiveSheet.Cells.AutoFilter Field:=columnIndex, Criteria1:="<>" & newName
    
    Call 删除所有可见行除了标题
    
    ActiveSheet.Cells.AutoFilter
    
    ActiveWorkbook.Save
    
    Dim newTitle As String
    
    newTitle = ActiveWindow.Caption
    
    Workbooks.Open (fullPath)
    
    Windows(newTitle).Close
    
    Windows(title).Activate
    
End Sub