Justin知识库 - Office
type: channel
link: https://just1n.cn/tag/Office/
items: 告别重复劳动！记录一下VBA脚本

告别重复劳动！记录一下VBA脚本
type: item
date: 2025-10-30T17:18:00+08:00
description: 这几天每天都在与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 …