告别重复劳动！记录一下VBA脚本

　　这几天每天都在与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界面
开发工具 → 宏
选择对应宏名 → 运行