如何修改VBA代码以移动非指定名称工作表到新工作簿并保存

修改后可直接使用的完整代码 #

Option Explicit

Sub MoveSheets()
Dim sPath As String
Dim sAddress As String
Dim wbCur As Workbook
Dim wsCur As Worksheet

'-- 存储当前工作簿路径 --
sPath = ThisWorkbook.Path & Application.PathSeparator

'-- 遍历所有工作表 --
For Each wsCur In ThisWorkbook.Worksheets
    ' 排除指定名称的工作表，不区分大小写匹配
    Select Case LCase(wsCur.Name)
        Case "valid", "control", "data"
            ' 匹配到排除名称直接进入下一轮循环
            GoTo NextSheet
    End Select
    
    On Error Resume Next
    Set wbCur = Nothing
    '-- 新建空白工作簿 --
    Set wbCur = Workbooks.Add
    On Error GoTo 0
    If wbCur Is Nothing Then
        '-- 异常报错提示 --
        MsgBox prompt:=Err.Description
    Else
        '-- 重命名新工作簿的第一张表 --
        wbCur.Sheets(1).Name = wsCur.Name
        '-- 获取原工作表使用区域地址 --
        sAddress = wsCur.UsedRange.Address
        '-- 复制粘贴数据 --
        wsCur.UsedRange.Copy Destination:=wbCur.Sheets(1).Range(sAddress)
        '-- 以工作表名作为文件名保存新工作簿 --
        wbCur.Close savechanges:=True, Filename:=sPath & wsCur.Name & ".xlsx"
    End If
NextSheet:
Next wsCur
End Sub

改动说明 #

• 新增了不区分大小写的名称匹配逻辑，避免因为工作表名大小写不一致导致过滤失效
• 匹配到valid、control、data三个名称的工作表时会直接跳过，不执行导出操作
• 原有导出逻辑完全保留，不会影响原本的运行效果

内容的提问来源于stack exchange，提问作者AKIRA