这几天每天都在与Excel打交道，重复着相同工作表的拆分、数据导出，今天分享一下这几天工作中常用的VBA脚本，让我从重复劳动中彻底解放，现在每天都能准时摸鱼！ 一键拆分多个工作表保存 使用场景：一个包含多个工作表的工作簿，要求每个表单独保存为文件时 Sub SplitWorkbookToCurrentFolder() Dim ws As Worksheet Dim newWorkbook As Workbook Dim savePath As String Dim fileName As String Dim originalWorkbook As Workbook Set originalWorkbook = ThisWorkbook ' 获取当前工作簿所在的文件夹路径 If originalWorkbook.Path <> "" Then savePath = originalWorkbook.Path & "\" Else ' 如果工作簿未保存，使用桌面路径 savePath = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\" MsgBox "当前工作簿尚未保存，文件将保存到桌面！", vbInformation End If Application.ScreenUpdating = False Application.DisplayAlerts = False On Error GoTo ErrorHandler For Each ws In originalWorkbook.Worksheets ' 复制工作表到新工作簿 ws.Copy Set newWorkbook = ActiveWorkbook ' 生成文件名：工作表名称 + 比对结果 fileName = savePath & ws.Name & "_比对结果.xlsx" ' 处理文件名重复的情况 If Dir(fileName) <> "" Then Dim counter As Integer counter = 1 Do While Dir(savePath & ws.Name & "_比对结果(" & counter & ").xlsx") <> "" counter = counter + 1 Loop fileName = savePath & ws.Name & "_比对结果(" & counter & ").xlsx" End If ' 保存文件 newWorkbook.SaveAs fileName, FileFormat:=xlOpenXMLWorkbook ' 关闭新工作簿 newWorkbook.Close SaveChanges:=False ' 释放对象 Set newWorkbook = Nothing Next ws Application.ScreenUpdating = True Application.DisplayAlerts = True MsgBox "所有工作表已成功保存为独立文件！" & vbNewLine & _ "保存路径：" & savePath, vbInformation, "完成" Exit Sub ErrorHandler: Application.ScreenUpdating = True Application.DisplayAlerts = True MsgBox "保存过程中出现错误：" & Err.Description, vbCritical, "错误" End Sub 表格一键导出为图片 需要将工作薄里各个工作表里的表格数据以图片形式保存 Sub ExportAllSheetsToImages() Dim ws As Worksheet Dim rng As Range Dim cht As ChartObject Dim savePath As String Dim fileName As String Dim lastRow As Long ' 设置保存路径为当前文件夹 savePath = ThisWorkbook.Path & "\" If savePath = "\" Then MsgBox "请先保存工作簿！", vbExclamation Exit Sub End If Application.ScreenUpdating = False Application.CutCopyMode = False For Each ws In ThisWorkbook.Worksheets If ws.Visible = xlSheetVisible Then ' 动态确定数据范围（从B1开始） With ws lastRow = .Cells(.Rows.Count, "B").End(xlUp).Row If lastRow < 1 Then lastRow = 1 Set rng = .Range("B1:H" & lastRow) End With ' 复制区域为图片 rng.CopyPicture Appearance:=xlScreen, Format:=xlPicture ' 创建图表对象 Set cht = ws.ChartObjects.Add(Left:=rng.Left, Top:=rng.Top, _ Width:=rng.Width, Height:=rng.Height) cht.Activate With cht.Chart ' 关键设置：透明背景 .ChartArea.Format.Fill.Visible = msoFalse .ChartArea.Format.Line.Visible = msoFalse .PlotArea.Format.Fill.Visible = msoFalse .PlotArea.Format.Line.Visible = msoFalse ' 粘贴图片 .Paste ' 生成文件名 fileName = savePath & CleanFileName(ws.Name) & ".png" ' 导出图片 .Export Filename:=fileName, FilterName:="PNG" End With ' 删除图表对象 cht.Delete End If Next ws Application.ScreenUpdating = True MsgBox "所有工作表已成功导出为图片！" & vbNewLine & "保存路径：" & savePath, vbInformation End Sub ' 清理文件名中的非法字符 Function CleanFileName(str As String) As String Dim illegalChars As String illegalChars = "\/:*?""<>|" Dim i As Integer For i = 1 To Len(illegalChars) str = Replace(str, Mid(illegalChars, i, 1), "") Next i CleanFileName = str End Function 使用指南 第一步：启用开发工具 文件 → 选项 → 自定义功能区 勾选“开发工具” → 点击确定 第二步：插入VBA代码 按 Alt + F11 打开VBA编辑器 右键项目 → 插入 → 模块 粘贴提供的代码 第三步：运行脚本 回到Excel界面 开发工具 → 宏 选择对应宏名 → 运行 温馨提示：首次使用建议备份文件，熟练后即可大胆使用！愿每一个努力的你，都能被温柔以待，准时下班！