VBA 自动化——用 AI 写你看不懂的宏

第15章：VBA 入门——让 Excel 帮你干重复的事

VBA（Visual Basic for Applications）是内置在 Excel 里的编程语言，它能让 Excel 自动执行一系列操作——就像在录一段"操作录像"然后随时回放，只不过可以做到远比录像更灵活的事情。本章的核心观点是：你不需要学会编程，只需要学会跟 AI 合作写 VBA 代码。 8个完整可运行的 VBA 案例，每个都附有 AI Prompt，让你直接上手。

VBA 是什么，为什么学

让 Excel 帮你干重复的事

你有没有过这样的经历：每周一上午花一小时手动把各部门发来的 Excel 表格合并成一张总表，每次都是同样的步骤，复制粘贴，调整格式，删除多余行……这类工作 枯燥、耗时、容易出错，而且完全没有创造性价值。

VBA 的意义就在于此：把这些重复性操作录制成代码，以后一键完成。 什么合并工作表、按部门拆分文件、批量格式化报表、自动发邮件……这些放在以前需要花几小时完成的工作，VBA 可以在几秒钟内完成。

适用场景

• 批量操作：对100个工作表做相同的格式修改；删除所有工作表中的某列；给所有工作簿加上统一的页眉页脚
• 自动生成报表：每天早上自动把数据汇总、计算、格式化，生成标准化的日报/周报
• 一键完成复杂任务：按某列值把一张表拆成多个文件并分别保存；把每个员工的工资条拆成独立的行并插入分隔行
• 与其他 Office 软件联动：在 Excel 里自动发 Outlook 邮件、操作 Word 文档、生成 PPT

不需要编程基础：AI 帮你写代码

很多人一听到"编程"两个字就退缩了。但本章的核心方法论是：你只需要描述清楚你想做什么，AI 来帮你写 VBA 代码。

你的角色变成了：

1. 明确说清楚需求（输入/输出/逻辑）
2. 把 AI 给的代码复制进 VBA 编辑器
3. 运行并看结果
4. 如果有问题，把错误信息告诉 AI，让它修复

当然，了解一些基础语法（下一节会讲）能帮你看懂代码、更准确地描述需求——但这些知识是辅助，不是门槛。

录制宏 vs 写代码

录制宏：零代码入门 VBA

录制宏是接触 VBA 最低门槛的方式：你正常操作 Excel，Excel 在后台把你的每一步操作翻译成 VBA 代码。下次只要运行这个宏，Excel 就会自动重复这些操作。

如何录制宏（步骤）

1. 点击"开发工具"选项卡 → "录制宏"（如果没有"开发工具"，先在 文件→选项→自定义功能区 中勾选它）
2. 给宏起一个名字（不能有空格，建议用英文），可选择快捷键
3. 点击"确定"，开始录制
4. 正常操作 Excel（格式化、筛选、复制粘贴等）
5. 完成后点击"停止录制"
6. 以后运行：开发工具 → 宏 → 选择宏名 → 运行

查看录制的代码

录制完成后，按 Alt+F11 打开 VBA 编辑器，在左侧"模块"下找到你的宏，就能看到 Excel 自动生成的代码。这是理解 VBA 代码的最好方式——先录制一遍，再看生成的代码，很多东西自然就明白了。

案例1：一键格式化报表

场景：每周需要对收到的数据报表做统一格式处理 标题行加粗、背景色设为深蓝、字体白色；数据行交替底色（浅蓝/白）；所有列自动调整宽度；加上所有边框。

我录制了一个 Excel 宏，代码如下：
[把录制的代码粘贴在这里]

存在的问题：
1. 代码里的行数/列数是写死的，我希望能自动识别数据的实际范围
2. 如果运行出错，希望有友好的错误提示而不是直接崩溃
3. 操作完成后弹出一个消息框告诉我处理了多少行

请帮我优化这段代码，保留原有功能，解决上述问题。

VBA 基础语法：看懂 AI 生成的代码

你不需要记住所有语法，但理解以下基础概念能帮你看懂 AI 生成的代码，以及更准确地描述需求。

变量声明

Dim lastRow As Long ' 声明整数变量 Dim sheetName As String ' 声明字符串变量 Dim ws As Worksheet ' 声明工作表对象 Dim rng As Range ' 声明单元格区域对象

' 赋值 lastRow = 100 sheetName = "销售数据" Set ws = ActiveSheet ' 对象赋值要加 Set

条件判断

If 条件 Then ' 满足条件时执行 ElseIf 另一个条件 Then ' 满足另一个条件时执行 Else ' 都不满足时执行 End If

' 示例：根据值设置颜色 If ws.Cells(i, 3).Value > 100000 Then ws.Cells(i, 3).Interior.Color = RGB(198, 239, 206) ' 绿色 ElseIf ws.Cells(i, 3).Value

循环

' For...Next 循环（已知次数） For i = 1 To 100 ' 处理第 i 行 Next i

' For Each 循环（遍历集合） Dim ws As Worksheet For Each ws In ThisWorkbook.Worksheets ws.Range("A1").Value = "标题" Next ws

' Do While 循环（条件循环） Dim i As Long i = 2 Do While ws.Cells(i, 1).Value <> "" ' 处理非空行 i = i + 1 Loop

Sub 与 Function 的区别

' Sub：执行一系列操作，无返回值 Sub MyMacro() MsgBox "Hello, VBA!" End Sub

' Function：执行计算并返回一个值，可在单元格公式中调用 Function TaxAmount(salary As Double) As Double TaxAmount = salary * 0.2 End Function ' 在单元格中使用：=TaxAmount(A2)

调试方法

• F8 逐步执行：在 VBA 编辑器中按 F8，代码会一行一行地执行，你可以观察每一步的效果，鼠标悬停在变量上查看当前值
• 立即窗口（Ctrl+G）：在代码中加入 Debug.Print 变量名，运行时变量的值会打印到立即窗口，用于诊断问题
• 断点（F9）：点击代码行左边的灰色边栏添加断点，代码运行到这里时会自动暂停

用 AI 写 VBA：8 个完整案例

这是本章最重要的部分。以下 8 个案例都附有需求描述、AI Prompt、完整 VBA 代码和使用说明。复制代码，按 Alt+F11 打开 VBA 编辑器，在"插入"菜单选"模块"，粘贴代码，按 F5 或点绿色播放键运行。

AI 写 VBA 的正确 Prompt 模板

案例1：批量合并多个工作表到一张总表

需求 一个工作簿里有多个工作表（Sheet1、Sheet2…），结构相同，第一行是标题。把所有工作表的数据合并到一个叫"总表"的新工作表里，标题只保留一次。

Sub MergeAllSheets() Dim ws As Worksheet Dim masterWs As Worksheet Dim lastRow As Long Dim masterLastRow As Long Dim headerCopied As Boolean

' 删除已有的"总表"，重新创建
Application.DisplayAlerts = False
On Error Resume Next
ThisWorkbook.Worksheets("总表").Delete
On Error GoTo 0
Application.DisplayAlerts = True

Set masterWs = ThisWorkbook.Worksheets.Add(After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count))
masterWs.Name = "总表"

headerCopied = False
masterLastRow = 1

' 遍历所有工作表（跳过"总表"本身）
For Each ws In ThisWorkbook.Worksheets
    If ws.Name <> "总表" Then
        lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row

        If lastRow >= 1 Then
            If Not headerCopied Then
                ' 复制标题行（第一张表的第一行）
                ws.Rows(1).Copy masterWs.Rows(1)
                masterLastRow = 2
                headerCopied = True
            End If

            If lastRow > 1 Then
                ' 复制数据行（跳过标题行）
                ws.Rows("2:" & lastRow).Copy masterWs.Rows(masterLastRow)
                masterLastRow = masterLastRow + lastRow - 1
            End If
        End If
    End If
Next ws

masterWs.Columns.AutoFit
MsgBox "合并完成！共合并 " & (masterLastRow - 2) & " 行数据到"总表"。", vbInformation

End Sub

案例2：按列值拆分工作表（按部门拆分为多个 Sheet）

Sub SplitByDepartment() ' 按B列（部门）的值，把数据拆分到各部门独立的工作表 Dim ws As Worksheet Dim newWs As Worksheet Dim lastRow As Long Dim i As Long Dim deptName As String Dim deptDict As Object

Set ws = ActiveSheet
lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
Set deptDict = CreateObject("Scripting.Dictionary")

Application.ScreenUpdating = False

' 收集所有不重复的部门名称
For i = 2 To lastRow
    deptName = ws.Cells(i, 2).Value  ' B列是部门
    If deptName <> "" And Not deptDict.Exists(deptName) Then
        deptDict.Add deptName, True

        ' 为每个部门创建工作表
        Application.DisplayAlerts = False
        On Error Resume Next
        ThisWorkbook.Worksheets(deptName).Delete
        On Error GoTo 0
        Application.DisplayAlerts = True

        Set newWs = ThisWorkbook.Worksheets.Add(After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count))
        newWs.Name = deptName
        ' 复制标题行
        ws.Rows(1).Copy newWs.Rows(1)
    End If
Next i

' 把每一行数据复制到对应部门的工作表
For i = 2 To lastRow
    deptName = ws.Cells(i, 2).Value
    If deptName <> "" Then
        Set newWs = ThisWorkbook.Worksheets(deptName)
        Dim destRow As Long
        destRow = newWs.Cells(newWs.Rows.Count, 1).End(xlUp).Row + 1
        ws.Rows(i).Copy newWs.Rows(destRow)
    End If
Next i

' 所有部门工作表自动调整列宽
Dim dept As Variant
For Each dept In deptDict.Keys
    ThisWorkbook.Worksheets(dept).Columns.AutoFit
Next dept

Application.ScreenUpdating = True
MsgBox "拆分完成！共创建 " & deptDict.Count & " 个部门工作表。", vbInformation

End Sub

案例3：批量修改所有工作表的格式

Sub FormatAllSheets() ' 对工作簿中所有工作表统一应用格式 Dim ws As Worksheet Dim lastRow As Long Dim lastCol As Long

Application.ScreenUpdating = False

For Each ws In ThisWorkbook.Worksheets
    lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
    lastCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column

    If lastRow >= 1 And lastCol >= 1 Then
        ' 标题行格式
        With ws.Rows(1)
            .Font.Bold = True
            .Font.Size = 11
            .Interior.Color = RGB(31, 78, 121)
            .Font.Color = RGB(255, 255, 255)
            .RowHeight = 24
        End With

        ' 数据区域字体统一
        ws.Range(ws.Cells(2, 1), ws.Cells(lastRow, lastCol)).Font.Size = 10

        ' 自动列宽
        ws.Columns(1).Resize(1, lastCol).AutoFit

        ' 页面设置：横向打印，A4纸
        With ws.PageSetup
            .Orientation = xlLandscape
            .PaperSize = xlPaperA4
            .FitToPagesWide = 1
            .FitToPagesTall = False
        End With
    End If
Next ws

Application.ScreenUpdating = True
MsgBox "已完成对 " & ThisWorkbook.Worksheets.Count & " 个工作表的格式设置。", vbInformation

End Sub

案例4：自动发送 Outlook 邮件（含附件）

⚠️ Warning

**前提条件：**本代码需要电脑上安装了 Outlook 并配置了邮件账户。在 VBA 编辑器中，需要先在"工具→引用"中勾选"Microsoft Outlook xx.x Object Library"。

Sub SendEmailWithAttachment() ' 读取工作表中的收件人列表，逐一发送邮件 ' 数据结构：A列=姓名，B列=邮箱地址，C列=附件路径（可选） Dim outlookApp As Object Dim mailItem As Object Dim ws As Worksheet Dim lastRow As Long Dim i As Long Dim sentCount As Long

Set ws = ActiveSheet
lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row

Set outlookApp = CreateObject("Outlook.Application")
sentCount = 0

For i = 2 To lastRow
    Dim recipientName As String
    Dim recipientEmail As String
    Dim attachPath As String

    recipientName = ws.Cells(i, 1).Value
    recipientEmail = ws.Cells(i, 2).Value
    attachPath = ws.Cells(i, 3).Value  ' C列：附件路径，可为空

    If recipientEmail <> "" Then
        Set mailItem = outlookApp.CreateItem(0)  ' 0 = olMailItem

        With mailItem
            .To = recipientEmail
            .Subject = "【月度报告】2024年3月数据报告"
            .Body = "尊敬的 " & recipientName & "，" & vbCrLf & vbCrLf & _
                    "请查收附件中的月度数据报告，如有疑问欢迎回复此邮件。" & vbCrLf & vbCrLf & _
                    "祝好，" & vbCrLf & "数据分析团队"

            If attachPath <> "" And Dir(attachPath) <> "" Then
                .Attachments.Add attachPath
            End If

            .Send  ' 直接发送；改为 .Display 则仅打开草稿不自动发送
        End With

        sentCount = sentCount + 1
    End If

    Set mailItem = Nothing
Next i

Set outlookApp = Nothing
MsgBox "邮件发送完成！共发送 " & sentCount & " 封。", vbInformation

End Sub

案例5：一键生成工资条（每人一行拆分）

Sub GeneratePaystubs() ' 把工资表（每人一行）转换为工资条格式（每人：标题行+数据行+空行） Dim srcWs As Worksheet Dim destWs As Worksheet Dim lastRow As Long Dim lastCol As Long Dim i As Long Dim destRow As Long

Set srcWs = ActiveSheet
lastRow = srcWs.Cells(srcWs.Rows.Count, 1).End(xlUp).Row
lastCol = srcWs.Cells(1, srcWs.Columns.Count).End(xlToLeft).Column

' 创建工资条工作表
Application.DisplayAlerts = False
On Error Resume Next
ThisWorkbook.Worksheets("工资条").Delete
On Error GoTo 0
Application.DisplayAlerts = True

Set destWs = ThisWorkbook.Worksheets.Add(After:=srcWs)
destWs.Name = "工资条"

destRow = 1
Application.ScreenUpdating = False

' 为每个员工生成：标题行 + 数据行 + 空行
For i = 2 To lastRow
    ' 复制标题行
    srcWs.Rows(1).Copy destWs.Rows(destRow)
    destRow = destRow + 1

    ' 复制员工数据行
    srcWs.Rows(i).Copy destWs.Rows(destRow)
    destRow = destRow + 1

    ' 插入空行（分隔线）
    destRow = destRow + 1
Next i

destWs.Columns.AutoFit
Application.ScreenUpdating = True
MsgBox "工资条生成完成！共 " & (lastRow - 1) & " 份工资条，保存在"工资条"工作表。", vbInformation

End Sub

案例6：批量替换多个工作簿的内容

Sub BatchReplaceInFolder() ' 对指定文件夹中所有 .xlsx 文件执行查找替换 Dim folderPath As String Dim fileName As String Dim wb As Workbook Dim ws As Worksheet Dim findText As String Dim replaceText As String Dim processedCount As Long

folderPath = "C:\Reports\"          ' 修改为你的目标文件夹路径
findText = "2023年"                  ' 要替换的内容
replaceText = "2024年"              ' 替换为的内容
processedCount = 0

Application.ScreenUpdating = False
Application.DisplayAlerts = False

fileName = Dir(folderPath & "*.xlsx")

Do While fileName <> ""
    Set wb = Workbooks.Open(folderPath & fileName)

    For Each ws In wb.Worksheets
        ws.Cells.Replace What:=findText, Replacement:=replaceText, _
            LookAt:=xlPart, MatchCase:=False
    Next ws

    wb.Save
    wb.Close
    processedCount = processedCount + 1
    fileName = Dir()
Loop

Application.ScreenUpdating = True
Application.DisplayAlerts = True
MsgBox "批量替换完成！共处理 " & processedCount & " 个文件。", vbInformation

End Sub

案例7：自动备份文件（带时间戳）

Sub AutoBackup() ' 把当前工作簿另存一份，文件名加上当前时间戳 Dim originalPath As String Dim backupPath As String Dim backupFolder As String Dim timestamp As String

originalPath = ThisWorkbook.FullName
backupFolder = ThisWorkbook.Path & "\Backup\"
timestamp = Format(Now(), "YYYY-MM-DD_HH-MM-SS")

' 创建 Backup 文件夹（如果不存在）
If Dir(backupFolder, vbDirectory) = "" Then
    MkDir backupFolder
End If

' 构造备份文件名：原文件名_时间戳.xlsx
Dim baseName As String
baseName = Left(ThisWorkbook.Name, InStrRev(ThisWorkbook.Name, ".") - 1)
backupPath = backupFolder & baseName & "_" & timestamp & ".xlsx"

' 保存当前文件并另存备份
ThisWorkbook.Save
ThisWorkbook.SaveCopyAs backupPath

MsgBox "备份成功！" & vbCrLf & "备份路径：" & backupPath, vbInformation

End Sub

案例8：数据录入自动验证 + 保存日志

Sub ValidateAndLog() ' 对当前工作表的数据做验证，并把问题记录到日志工作表 Dim ws As Worksheet Dim logWs As Worksheet Dim lastRow As Long Dim i As Long Dim errorCount As Long Dim logRow As Long

Set ws = ActiveSheet
lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
errorCount = 0

' 获取或创建日志工作表
On Error Resume Next
Set logWs = ThisWorkbook.Worksheets("验证日志")
On Error GoTo 0

If logWs Is Nothing Then
    Set logWs = ThisWorkbook.Worksheets.Add(After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count))
    logWs.Name = "验证日志"
    logWs.Range("A1:E1").Value = Array("检查时间", "行号", "姓名", "错误字段", "错误描述")
End If

logRow = logWs.Cells(logWs.Rows.Count, 1).End(xlUp).Row + 1

For i = 2 To lastRow
    Dim errMsg As String
    errMsg = ""

    ' 规则1：A列（姓名）不能为空
    If ws.Cells(i, 1).Value = "" Then
        errMsg = "姓名不能为空"
        ws.Cells(i, 1).Interior.Color = RGB(255, 199, 206)
    End If

    ' 规则2：C列（薪资）必须是正数
    If Not IsNumeric(ws.Cells(i, 3).Value) Or ws.Cells(i, 3).Value  "" Then errMsg = errMsg & "；"
        errMsg = errMsg & "薪资必须是正数"
        ws.Cells(i, 3).Interior.Color = RGB(255, 199, 206)
    End If

    ' 规则3：B列（部门）不能为空
    If ws.Cells(i, 2).Value = "" Then
        If errMsg <> "" Then errMsg = errMsg & "；"
        errMsg = errMsg & "部门不能为空"
        ws.Cells(i, 2).Interior.Color = RGB(255, 199, 206)
    End If

    If errMsg <> "" Then
        logWs.Cells(logRow, 1).Value = Now()
        logWs.Cells(logRow, 2).Value = i
        logWs.Cells(logRow, 3).Value = ws.Cells(i, 1).Value
        logWs.Cells(logRow, 4).Value = "多字段"
        logWs.Cells(logRow, 5).Value = errMsg
        logRow = logRow + 1
        errorCount = errorCount + 1
    End If
Next i

logWs.Columns.AutoFit

If errorCount = 0 Then
    MsgBox "验证通过！所有 " & (lastRow - 1) & " 条数据均符合规则。", vbInformation
Else
    MsgBox "发现 " & errorCount & " 行存在问题，详情请查看"验证日志"工作表。问题单元格已标红。", vbExclamation
End If

End Sub

VBA 调试与常见错误

4 种常见错误类型 + AI 修复 Prompt

错误类型1：运行时错误 1004 — 应用程序或对象定义的错误

通常原因：引用了不存在的工作表名称，或者操作了受保护的区域。

**AI 修复 Prompt：**我的 VBA 代码运行时出现"运行时错误 1004：应用程序或对象定义的错误"，错误发生在这一行：[把出错的代码行粘贴这里]。代码的功能是[描述功能]。请告诉我原因并给出修复方法。

错误类型2：运行时错误 91 — 对象变量或 With 块变量未设置

通常原因：对象变量没有用 Set 赋值，或者对象为 Nothing（例如 Find 方法没找到结果就直接使用）。

**AI 修复 Prompt：**Excel VBA 报"运行时错误 91：对象变量或 With 块变量未设置"，完整代码如下：[粘贴代码]。我要实现的功能是[描述]，请找出问题并修复，同时说明这类错误的原因。

错误类型3：运行时错误 9 — 下标越界

通常原因：访问了不存在的工作表（按名称或索引），或者数组索引超出了范围。

**AI 修复 Prompt：**VBA 运行时报"下标越界"错误，出错代码是：[粘贴代码行]。我的工作簿结构是：[描述工作表名称和数量]。请帮我找出越界的原因并修复。

错误类型4：编译错误 — 预期 Sub 或 Function

通常原因：代码结构有问题，通常是 Sub/End Sub 不匹配，或者在 Sub 外面写了语句。

**AI 修复 Prompt：**Excel VBA 报编译错误"预期 Sub 或 Function"，无法运行。我的完整代码是：[粘贴全部代码]。请找出结构问题并修复，确保代码可以正常运行。

安全注意事项

❌ Caution

绝对不要运行来历不明的宏！

VBA 宏可以执行任意文件操作、网络请求、系统命令。收到含宏的 Excel 文件时，除非你完全信任发送者，否则绝对不要启用宏。勒索软件和数据窃取程序很多就是通过 Excel 宏传播的。

• 宏安全设置：文件 → 选项 → 信任中心 → 信任中心设置 → 宏设置。建议选"禁用所有宏，并发出通知"，手动决定是否启用。
• 不要禁用所有警告：代码里写 Application.DisplayAlerts = False 是正常的（避免弹窗打断操作），但记得在代码末尾恢复为 True。
• 保存为 .xlsm：含宏的文件必须保存为 .xlsm 格式，.xlsx 格式不支持宏。
• 测试时先备份：运行任何会修改/删除数据的宏之前，先备份文件。

VBA 常用代码片段速查

✅ Tip

本章核心总结：

VBA 的门槛比你想象的低得多——有了 AI，你不需要自己学语法，只需要描述清楚需求。录制宏是入门，AI 写代码是主力，调试时把错误信息直接告诉 AI 让它修复。8个案例覆盖了职场中最常见的自动化需求，直接复制使用，按需修改参数即可。

上一章 ← 第14章：动态数组函数 下一章 第16章：Python + Excel 自动化 →