一个用来把一个工作簿按其中一个工作表关键词列拆分成多个工作簿的VBA代码

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