Excel VBA如何将ListBox选中的工作表保存为单个新工作簿

原有代码核心问题 #

• 未判断用户是否选中工作表，当SheetArray为空时直接调用会触发下标越界错误
• 错误调用Sheets集合的SaveAs方法，SaveAs是工作簿（Workbook）对象的专属方法，直接对工作表集合调用会导致逻辑异常
• 直接在原工作簿执行操作会修改原工作簿的保存状态，存在原文件内容被覆盖的风险
• 未配置保存格式参数，高版本Excel保存为.xls格式时会频繁弹出兼容告警
• 声明了未使用的变量c，属于冗余代码，已清理

修改后完整代码 #

Sub test()
    Dim i As Long, d As Long, FName As String, savePath As String
    ' 可按需修改文件名和后缀，旧版Excel兼容格式可将后缀改为.xls
    FName = "Sheet.xlsx"
    Dim SheetArray() As String
    
    ' 临时关闭系统告警，避免兼容提示干扰
    Application.DisplayAlerts = False
    
    ' 读取ListBox选中的工作表名称
    With ActiveSheet.ListBoxSh
        For i = 0 To .ListCount - 1
            If .Selected(i) Then
                ReDim Preserve SheetArray(d)
                SheetArray(d) = .List(i)
                d = d + 1
            End If
        Next i
    End With
    
    ' 无选中工作表时直接退出
    If d = 0 Then
        MsgBox "请至少选择一个工作表后再执行操作"
        Application.DisplayAlerts = True
        Exit Sub
    End If
    
    ' 核心逻辑：将选中的工作表批量复制为全新独立工作簿
    Sheets(SheetArray).Copy
    savePath = Environ("temp") & "\" & FName
    ' 保存新工作簿，xlsx格式对应xlOpenXMLWorkbook，xls格式对应xlExcel8
    ActiveWorkbook.SaveAs Filename:=savePath, FileFormat:=xlOpenXMLWorkbook
    
    ' 如需保存后自动关闭新工作簿，可取消下行注释
    ' ActiveWorkbook.Close SaveChanges:=False
    
    MsgBox "导出成功，文件保存路径：" & savePath
    ' 恢复系统告警默认配置
    Application.DisplayAlerts = True
End Sub

可选调整说明 #

• 如需导出为Excel 97-2003兼容的.xls格式，将FName的后缀改为.xls，同时将FileFormat参数值改为xlExcel8即可
• 如需让用户自主选择保存路径，可调用Application.GetSaveAsFilename方法替换固定的savePath配置

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