vba批量拆分sheet到指定文件夹（包含过滤特定sheet）

Dl1Ft3Ht9

Sub SplitSheetsToFiles()
    Dim wb As Workbook
    Dim ws As Worksheet
    Dim newWb As Workbook
    Dim folderPath As String
    Dim sheetName As String
    Dim excludedSheets As Variant
    Dim savePath As String
    Dim i As Integer

    ' 获取当前工作簿
    Set wb = ThisWorkbook

    ' 设置要保存工作簿的文件夹路径
    folderPath = "C:\Your\Folder\Path\"  ' 请更改为你想要保存的文件夹路径

    ' 设置要排除的工作表名称数组（可以根据需要进行修改）
    excludedSheets = Array("Sheet1", "Sheet2")  ' 假设要排除这两个工作表

    ' 检查文件夹是否存在，如果不存在，则创建该文件夹
    If Dir(folderPath, vbDirectory) = "" Then
        MkDir folderPath
    End If

    ' 遍历工作簿中的所有工作表
    For Each ws In wb.Sheets
        sheetName = ws.Name

        ' 如果工作表名称在排除的列表中，则跳过
        If IsError(Application.Match(sheetName, excludedSheets, 0)) Then
            ' 创建一个新的工作簿
            Set newWb = Workbooks.Add
            ws.Copy Before:=newWb.Sheets(1)

            ' 删除新工作簿中默认的空白工作表
            Application.DisplayAlerts = False
            newWb.Sheets(2).Delete
            Application.DisplayAlerts = True

            ' 保存新的工作簿到指定文件夹
            savePath = folderPath & sheetName & ".xlsx"
            newWb.SaveAs savePath

            ' 关闭新工作簿
            newWb.Close SaveChanges:=False
        End If
    Next ws

    MsgBox "所有工作表已成功拆分并保存到指定文件夹！", vbInformation
End Sub

losingstars

昨天还发愁怎么拆分sheet到文件呢，今天就看到有人发了，谢谢楼主，下来试试。

Wapj_Wolf

这个必须拿来备着啊，虽然现在没有拆分的需求。

anson1599

之前也写过一个自己用的，发出来参考一下，支持选择文件和拖拽文件到 vbs 脚本上

[Asm] 纯文本查看 复制代码

?

01 02 03 04 05 06 07 08 09 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80

Option Explicit   ' 将Excel文件内的工作表在原目录内单独保存为新文件，选是加序号，选否无序号   Function SplitSheets(File, order)     Dim oXls, SheetsCount, OrderNumber, i     Set oXls = oExcel.Workbooks.Open(File)     SheetsCount = oXls.Sheets.Count - 1 ' 取工作表数量     OrderNumber = "" ' 定义前缀序号     Dim SheetArray()     ReDim SheetArray(SheetsCount) ' 定义数组     If SheetsCount = 0 Then         SheetArray(0) = "只有一个工作表不需要分割"     Else         For i = 0 To SheetsCount             If order Then OrderNumber = Right("0" & i, 2) & "."             SheetArray(i) = oXls.Path & "\" & OrderNumber & oXls.Sheets(i + 1).Name & ".xlsx"             oXls.Sheets(i + 1).Copy ' 复制工作表             oExcel.ActiveWorkbook.SaveAs(SheetArray(i)) ' 另存工作表为新文件             oExcel.ActiveWorkbook.Close         Next     End If     oXls.Close     Set oXls = Nothing     SplitSheets = Join(SheetArray, vbCrLf) ' 返回文件名 End Function   Dim FileCount FileCount = WScript.Arguments.Count   If FileCount = 1 Then  ' 拖拽文件     FileName = WScript.Arguments(0)     If LCase(Right(FileName, 4)) <> ".xls" And LCase(Right(FileName, 5)) <> ".xlsx" Then         MsgBox "只能处理 Excel 格式的文件", vbCritical, "错误"         WScript.Quit     End If End If   If FileCount < 2 Then     Dim oExcel, FileName     On Error Resume Next     Set oExcel = WScript.CreateObject("Excel.Application")     If Err.Number <> 0 Then         MsgBox "无法创建 Excel 组件，请安装 Office 后执行", vbCritical, "错误"         WScript.Quit     End If       If FileCount = 0 Then ' 无拖拽文件打开文件选择框         Dim FileDialog         Set FileDialog = oExcel.FileDialog(3)         FileDialog.Filters.Add "Excel 文件", "*.xls; *.xlsx"         FileDialog.AllowMultiSelect = False         'FileDialog.InitialFileName = "默认路径"         FileDialog.show()           If FileDialog.SelectedItems.Count = 1 Then             FileName = FileDialog.SelectedItems(1)         End If           Set FileDialog = Nothing     End If       If Not IsEmpty(FileName) Then         Dim Response         Response = MsgBox("选择 是：分割工作表到新文件（带序号）" & vbCrLf & "选择 否：分割工作表到新文件（无序号）", vbQuestion + vbYesNoCancel, "选择处理方式")         If Response = vbYes Then             MsgBox SplitSheets(FileName, True), vbInformation, "分割完成"         End If         If Response = vbNo Then             MsgBox SplitSheets(FileName, False), vbInformation, "分割完成"         End If     End If     oExcel.Quit     Set oExcel = Nothing   Else       MsgBox "只能处理 1 个 Excel 文件", vbCritical, "错误"   End If

msmvc

有用，谢谢分享

firebo

平常跟数据打交道多的人很有用，可以再多考虑几个应用场景，比如自动拆分到excel所在路径识别，全部sheet拆分开关等，一些浅见，仅供参考。

3291952274

NB大佬感谢源码

1qaz

有没有全部的工作表合并一个工作表的？

Amarry

谢谢分享~~~

hlw2008

谢谢分享~~