Excel VBA 自动化与综合实战教程

第五编 VBA 自动化与综合实战

0. VBA 与综合实战模块导学

适用环境：Windows 版 Excel 2016/2019/2021/Microsoft 365。Mac 版可运行大部分 VBA，但 ActiveX、部分文件对话框和 Windows API 不兼容。本文所有代码默认保存在启用宏的工作簿 .xlsm 中，模块顶部统一使用 Option Explicit。示例路径请改为自己电脑上的实际路径。

0. 学习目标、准备与安全约定

完成本模块后，你应能：

录制并清理宏。
在 VBE 中组织标准模块、工作表模块、ThisWorkbook 和 UserForm。
理解对象、属性、方法、事件。
正确声明变量。
使用分支、循环、数组和字典。
稳健定位数据区域。
遍历工作表、工作簿并批量处理文件。
建立统一错误处理和性能恢复框架。
编写事件与窗体程序。
调试、签名并安全分发宏。
独立完成销售看板、预算敏感性分析、文件批量汇总三个项目。

0.1 开启开发工具

1. Windows：文件 → 选项 → 自定义功能区，勾选“开发工具”。

2. 新建工作簿，立即执行文件 → 另存为，类型选“Excel 启用宏的工作簿（*.xlsm）”。

3. 按 Alt+F11 打开 Visual Basic Editor（VBE）。按 Ctrl+R 显示工程资源管理器，按 F4 显示属性窗口，按 Ctrl+G 显示立即窗口。

4. 在 VBE 中执行工具 → 选项 → 编辑器，勾选“要求变量声明”。以后新模块会自动出现 Option Explicit。

5. 只对来源可信的文件启用宏。不要选择“启用所有宏”；优先使用受信任位置或数字签名。

0.2 教材示例数据粘贴规则

代码块中的制表符数据可整体复制，并从目标工作表 A1 粘贴。日期列必须存为 Excel 日期值，金额和数量列必须存为数值。若所有字段都挤在一列，请执行“数据→分列→分隔符号→制表符”。

0.3 第一个统一测试程序

在 VBE 中执行插入 → 模块，粘贴并按 F5：

Option Explicit

Public Sub 环境自检()
    Dim msg As String
    msg = "Excel版本：" & Application.Version & vbCrLf & _
          "工作簿：" & ThisWorkbook.Name & vbCrLf & _
          "路径：" & ThisWorkbook.Path
    MsgBox msg, vbInformation, "VBA环境正常"
End Sub

结果检查：消息框应显示版本、当前宏工作簿名和保存路径。若路径为空，说明文件尚未保存。

1. 宏录制：从操作到代码

1.1 录制相对引用与绝对引用

宏录制器会把界面操作翻译成 VBA，是学习对象模型的“摄像机”，但生成代码通常冗长。

实验数据（粘贴到 Sheet1!A1）：

产品	数量	单价
键盘	12	129
鼠标	20	89
显示器	5	1599

逐步操作：

1. 开发工具 → 录制宏，宏名输入格式化表头，保存在“当前工作簿”。

2. 选 A1:C1，设置深蓝填充、白色粗体、居中；双击列边界自动调整列宽。

3. 开发工具 → 停止录制。

4. 按 Alt+F11，展开“模块”，观察 Selection、With、Font、Interior。

5. 回到 Excel，开发工具 → 宏 → 格式化表头 → 执行。

录制代码往往类似：

Sub 格式化表头_录制版()
    Range("A1:C1").Select
    With Selection.Font
        .Bold = True
        .Color = RGB(255, 255, 255)
    End With
    Selection.Interior.Color = RGB(31, 78, 121)
    Selection.HorizontalAlignment = xlCenter
    Columns("A:C").EntireColumn.AutoFit
End Sub

应清理为无需选择对象的版本：

Public Sub 格式化表头_推荐版()
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Worksheets("Sheet1")
    With ws.Range("A1:C1")
        .Font.Bold = True
        .Font.Color = vbWhite
        .Interior.Color = RGB(31, 78, 121)
        .HorizontalAlignment = xlCenter
    End With
    ws.Columns("A:C").AutoFit
End Sub

为什么推荐版更好：不依赖当前活动工作簿、工作表或选区；执行快；用户切换窗口也不容易写错位置。

1.2 相对引用

录制前点击“使用相对引用”，从当前单元格向右移动并写入公式，宏会使用 ActiveCell.Offset。相对宏适合对“当前选中行”执行相同操作；绝对宏适合固定模板。

常见故障：

宏列表看不到过程：过程必须是标准模块中的 Public Sub 名称()，不能带参数。
文件重开后宏消失：保存成了 .xlsx，应另存为 .xlsm。
宏操作错表：录制代码依赖 ActiveSheet；改为显式 ThisWorkbook.Worksheets("名称")。
录制代码很长：删除滚动、选择、激活、复制模式等无业务意义语句。

2. VBE、工程结构与 Option Explicit

一个 VBAProject 通常包含：

标准模块：放可复用过程、函数和公共常量。
工作表模块：放该工作表的 Worksheet_Change 等事件。
ThisWorkbook：放打开、关闭、保存等工作簿事件。
UserForm：窗体及控件事件。
类模块：封装自定义对象，进阶项目可使用。

推荐命名：modMain（入口）、modData（数据处理）、modReport（报表）、modUtils（工具）、frmFilter（窗体）。中文过程名可读性高，但团队跨语言协作时建议英文模块名和稳定的业务术语。

Option Explicit

Private Const APP_TITLE As String = "Excel自动化教程"
Public Const TAX_RATE As Double = 0.13

Public Sub 变量声明演示()
    Dim totalAmount As Double
    Dim orderCount As Long
    totalAmount = 12500.5
    orderCount = 18
    Debug.Print APP_TITLE, totalAmount / orderCount
End Sub

Option Explicit 会让未声明的 totlaAmount 在编译阶段暴露，而不是悄悄创建 Variant 并产生错误结果。执行调试 → 编译 VBAProject 可一次发现语法和声明问题。

作用域：过程内 Dim 只在过程内有效；模块顶部 Private 仅本模块可见；标准模块顶部 Public 整个工程可见。尽量缩小作用域，避免公共变量被意外修改。

3. 对象、属性、方法和事件

把 Excel 想成层级对象：Application → Workbooks → Workbook → Worksheets → Worksheet → Range。

对象：工作簿、工作表、单元格区域、图表。
属性：对象的状态，如 Range.Value2、Worksheet.Name。
方法：对象能执行的动作，如 Workbook.Save、Range.ClearContents。
事件：对象发生的事情，如 Workbook_Open、Worksheet_Change。

Public Sub 对象模型演示()
    Dim wb As Workbook
    Dim ws As Worksheet
    Dim rng As Range

    Set wb = ThisWorkbook
    Set ws = wb.Worksheets("Sheet1")
    Set rng = ws.Range("A1:C4")

    rng.Font.Name = "微软雅黑"          '属性
    rng.Borders.LineStyle = xlContinuous
    rng.Copy Destination:=ws.Range("E1") '方法
    Debug.Print wb.FullName, rng.Address
End Sub

对象变量必须用 Set。ThisWorkbook 指存放代码的工作簿；ActiveWorkbook 指界面当前激活的工作簿，两者可能不同。自动化模板应优先使用 ThisWorkbook 或显式变量。

With 可减少重复限定：

With ThisWorkbook.Worksheets("Sheet1").Range("A1:C1")
    .Font.Bold = True
    .Interior.Color = RGB(220, 230, 241)
    .Borders.LineStyle = xlContinuous
End With

4. 变量、常量与数据类型

常用类型：Byte、Integer、Long、LongLong（64位环境）、Single、Double、Currency、Decimal（Variant 子类型）、Boolean、Date、String、Variant、对象类型。

实践建议：

行号用 Long，不要用上限只有 32767 的 Integer。
金额可用 Currency，统计计算常用 Double。
日期用 Date。
未知输入才用 Variant。
对象声明到具体类型而非 Object，可获得自动补全。

Public Sub 类型演示()
    Dim rowNo As Long
    Dim amount As Currency
    Dim rate As Double
    Dim orderDate As Date
    Dim isValid As Boolean
    Dim customer As String
    Dim v As Variant

    rowNo = 1048576
    amount = CCur(12345.67)
    rate = CDbl("0.15")
    orderDate = DateSerial(2026, 7, 1)
    isValid = (amount > 0)
    customer = CStr("华东商贸")
    v = Empty

    Debug.Print rowNo, amount, rate, Format$(orderDate, "yyyy-mm-dd"), isValid, IsEmpty(v)
End Sub

输入转换前先验证：

Public Function 安全转数值(ByVal value As Variant, Optional ByVal defaultValue As Double = 0) As Double
    If IsError(value) Or IsEmpty(value) Or Trim$(CStr(value)) = "" Then
        安全转数值 = defaultValue
    ElseIf IsNumeric(value) Then
        安全转数值 = CDbl(value)
    Else
        安全转数值 = defaultValue
    End If
End Function

注意 Dim a, b As Long 中只有 b 是 Long，a 是 Variant；应写 Dim a As Long, b As Long。

5. 分支：If 与 Select Case

Public Function 绩效等级(ByVal achievement As Double) As String
    If achievement >= 1.2 Then
        绩效等级 = "卓越"
    ElseIf achievement >= 1 Then
        绩效等级 = "达标"
    ElseIf achievement >= 0.8 Then
        绩效等级 = "待提升"
    Else
        绩效等级 = "未达标"
    End If
End Function

Public Function 区域经理(ByVal region As String) As String
    Select Case Trim$(region)
        Case "华东": 区域经理 = "陈经理"
        Case "华南": 区域经理 = "林经理"
        Case "华北", "东北": 区域经理 = "周经理"
        Case Else: 区域经理 = "待分配"
    End Select
End Function

Select Case 也支持范围：Case Is >= 100，以及 Case 80 To 99。分支顺序应从更严格条件到更宽松条件，否则前面的条件会截获后续情况。

6. 循环：For、For Each 与 Do

Public Sub 三种循环()
    Dim i As Long, cell As Range, n As Long
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Worksheets("Sheet1")

    For i = 2 To 10
        ws.Cells(i, 4).Value = ws.Cells(i, 2).Value * ws.Cells(i, 3).Value
    Next i

    For Each cell In ws.Range("D2:D10")
        If IsNumeric(cell.Value) Then cell.NumberFormat = "¥#,##0.00"
    Next cell

    n = 2
    Do While ws.Cells(n, 1).Value <> ""
        ws.Cells(n, 5).Value = "已检查"
        n = n + 1
        If n > ws.Rows.Count Then Exit Do
    Loop
End Sub

删除行时从底向上：

For i = lastRow To 2 Step -1
    If ws.Cells(i, "A").Value = "" Then ws.Rows(i).Delete
Next i

否则删除后下一行上移，会被跳过。Do...Loop 必须设计退出条件，调试时若死循环可按 Ctrl+Break。

7. 数组与字典：从逐格处理到内存处理

逐单元格读写会频繁跨越 Excel 与 VBA 边界。把区域一次读入二维 Variant 数组，在内存计算后一次写回，通常快数十倍。

Public Sub 数组批量计算()
    Dim ws As Worksheet, data As Variant, output() As Variant
    Dim lastRow As Long, i As Long
    Set ws = ThisWorkbook.Worksheets("Sheet1")
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    If lastRow < 2 Then Exit Sub

    data = ws.Range("A2:C" & lastRow).Value2
    ReDim output(1 To UBound(data, 1), 1 To 1)
    For i = 1 To UBound(data, 1)
        If IsNumeric(data(i, 2)) And IsNumeric(data(i, 3)) Then
            output(i, 1) = CDbl(data(i, 2)) * CDbl(data(i, 3))
        Else
            output(i, 1) = CVErr(xlErrValue)
        End If
    Next i
    ws.Range("D2").Resize(UBound(output, 1), 1).Value = output
End Sub

字典适合去重、计数、映射和分组汇总。为避免引用版本问题，下面使用后期绑定：

Public Sub 字典区域汇总()
    Dim dict As Object, data As Variant, i As Long, key As String
    Dim ws As Worksheet, outRow As Long, k As Variant
    Set dict = CreateObject("Scripting.Dictionary")
    dict.CompareMode = vbTextCompare
    Set ws = ThisWorkbook.Worksheets("销售明细")
    data = ws.Range("A2").CurrentRegion.Value2

    For i = 2 To UBound(data, 1)
        key = Trim$(CStr(data(i, 2)))
        If Len(key) > 0 Then
            If Not dict.Exists(key) Then dict.Add key, 0#
            dict(key) = dict(key) + CDbl(data(i, 6))
        End If
    Next i

    With ThisWorkbook.Worksheets("区域汇总")
        .Cells.Clear
        .Range("A1:B1").Value = Array("区域", "销售额")
        outRow = 2
        For Each k In dict.Keys
            .Cells(outRow, 1).Value = k
            .Cells(outRow, 2).Value = dict(k)
            outRow = outRow + 1
        Next k
    End With
End Sub

字典键可能包含前后空格和大小写差异，入库前应 Trim$，并按业务选择 vbTextCompare。

8. Range、Cells 与可靠定位

Range("A1") 直观。
Cells(row, column) 适合循环。
Resize 改变尺寸。
Offset 偏移。
CurrentRegion 获取被空行空列包围的连续区域。
UsedRange 可能因历史格式膨胀。

Public Sub 区域定位示例()
    Dim ws As Worksheet, lastRow As Long, lastCol As Long
    Dim dataRange As Range
    Set ws = ThisWorkbook.Worksheets("Sheet1")

    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    lastCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
    Set dataRange = ws.Range(ws.Cells(1, 1), ws.Cells(lastRow, lastCol))
    Debug.Print dataRange.Address
End Sub

若 A 列可能为空，不应只凭 A 列找最后行。更稳健的函数：

Public Function 最后使用行(ByVal ws As Worksheet) As Long
    Dim found As Range
    Set found = ws.Cells.Find(What:="*", After:=ws.Cells(1, 1), _
        LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, _
        SearchDirection:=xlPrevious, MatchCase:=False)
    If found Is Nothing Then
        最后使用行 = 0
    Else
        最后使用行 = found.Row
    End If
End Function

Find 会记忆用户上一次查找参数，所以必须把关键参数写全。限定对象时，以下是错误与正确对照：

'错误：第二个 Cells 可能属于活动表
Set dataRange = ws.Range(ws.Cells(1, 1), Cells(lastRow, 6))
'正确：两个 Cells 都属于 ws
Set dataRange = ws.Range(ws.Cells(1, 1), ws.Cells(lastRow, 6))

9. 遍历工作表与工作簿

Public Sub 遍历本工作簿工作表()
    Dim ws As Worksheet
    For Each ws In ThisWorkbook.Worksheets
        If ws.Visible = xlSheetVisible Then
            Debug.Print ws.Index, ws.Name, 最后使用行(ws)
        End If
    Next ws
End Sub

Public Sub 遍历已打开工作簿()
    Dim wb As Workbook
    For Each wb In Application.Workbooks
        Debug.Print wb.Name, wb.Path, wb.ReadOnly
    Next wb
End Sub

批量创建月表时先判断是否存在：

Public Function 工作表存在(ByVal sheetName As String, ByVal wb As Workbook) As Boolean
    Dim ws As Worksheet
    On Error Resume Next
    Set ws = wb.Worksheets(sheetName)
    工作表存在 = Not ws Is Nothing
    On Error GoTo 0
End Function

不要长期使用 On Error Resume Next，它会隐藏真实错误；只包围预期可能失败的一两行并立即恢复。

10. 文件批处理基础

Dir 轻量、无需额外引用。始终排除当前汇总工作簿、临时锁文件 ~$，打开后保证关闭。

Public Sub 列出文件夹Excel文件()
    Dim folderPath As String, fileName As String, r As Long
    folderPath = ThisWorkbook.Path & Application.PathSeparator & "待处理"
    If Dir(folderPath, vbDirectory) = "" Then
        MsgBox "文件夹不存在：" & folderPath, vbExclamation
        Exit Sub
    End If

    fileName = Dir(folderPath & Application.PathSeparator & "*.xls*")
    r = 2
    Do While Len(fileName) > 0
        If Left$(fileName, 2) <> "~$" Then
            Cells(r, 1).Value = fileName
            r = r + 1
        End If
        fileName = Dir()
    Loop
End Sub

文件选择器示例：

Public Function 选择文件夹() As String
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "选择包含Excel文件的文件夹"
        .AllowMultiSelect = False
        If .Show <> -1 Then Exit Function
        选择文件夹 = .SelectedItems(1)
    End With
End Function

Mac 或受限环境中 FileDialog 行为可能不同，可改用配置表单元格保存路径。

11. 错误处理：既报告也恢复环境

推荐结构包含入口、正常出口、错误出口和统一清理。错误信息至少记录过程、编号、描述、时间和文件。

Public Sub 稳健任务模板()
    Dim oldCalc As XlCalculation
    On Error GoTo ErrHandler

    oldCalc = Application.Calculation
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.DisplayAlerts = False
    Application.Calculation = xlCalculationManual

    '此处执行核心任务
    ThisWorkbook.Worksheets("Sheet1").Range("F1").Value = Now

CleanExit:
    Application.Calculation = oldCalc
    Application.DisplayAlerts = True
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    Application.StatusBar = False
    Exit Sub

ErrHandler:
    MsgBox "任务失败" & vbCrLf & _
           "错误号：" & Err.Number & vbCrLf & _
           "说明：" & Err.Description, vbCritical
    Resume CleanExit
End Sub

即使发生错误，也必须重新开启事件和屏幕刷新。若 Excel 曾因中断保持 EnableEvents=False，可在立即窗口输入 Application.EnableEvents=True 回车恢复。

日志函数：

Public Sub 写日志(ByVal procName As String, ByVal message As String, Optional ByVal level As String = "INFO")
    Dim ws As Worksheet, r As Long
    Set ws = ThisWorkbook.Worksheets("运行日志")
    r = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row + 1
    If r < 2 Then r = 2
    ws.Cells(r, 1).Resize(1, 4).Value = Array(Now, level, procName, message)
End Sub

12. 性能优化

1. 一次读取数组、一次写回，避免逐格交互。

2. 关闭 ScreenUpdating、事件和自动计算，并在清理段恢复原状态。

3. 避免 Select、Activate、剪贴板复制；优先直接赋值。

4. 对海量查找，字典优于双层循环；先筛选再处理。

5. 限定区域，不使用整列数组或无边界 UsedRange。

6. 不在循环内反复创建对象或调用易变工作表函数。

7. 用 Timer 测量，而不是凭感觉优化。

Public Sub 性能计时示例()
    Dim t As Double, data As Variant, i As Long
    t = Timer
    data = ThisWorkbook.Worksheets("Sheet1").Range("A1:D10000").Value2
    For i = 2 To UBound(data, 1)
        If IsNumeric(data(i, 2)) And IsNumeric(data(i, 3)) Then data(i, 4) = data(i, 2) * data(i, 3)
    Next i
    ThisWorkbook.Worksheets("Sheet1").Range("A1:D10000").Value2 = data
    Debug.Print "耗时(秒)："; Format$(Timer - t, "0.000")
End Sub

午夜跨越会让 Timer 归零；长期计时可使用日期时间差。

13. 事件程序

将下面代码放入具体工作表模块，而非标准模块：

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim watchRange As Range, cell As Range
    On Error GoTo CleanExit
    Set watchRange = Intersect(Target, Me.Range("B2:B1000"))
    If watchRange Is Nothing Then Exit Sub

    Application.EnableEvents = False
    For Each cell In watchRange.Cells
        If Len(cell.Value) > 0 And Not IsNumeric(cell.Value) Then
            cell.ClearContents
            MsgBox "数量必须是数值。", vbExclamation
        ElseIf IsNumeric(cell.Value) And cell.Value < 0 Then
            cell.Value = Abs(cell.Value)
        End If
    Next cell
CleanExit:
    Application.EnableEvents = True
End Sub

将下面代码放入 ThisWorkbook：

Option Explicit

Private Sub Workbook_Open()
    ThisWorkbook.Worksheets("首页").Activate
    Application.StatusBar = "欢迎使用销售管理工作簿"
End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)
    Application.StatusBar = False
End Sub

事件最常见风险是递归：事件中修改单元格会再次触发事件，必须临时关闭 EnableEvents 并保证恢复。事件内避免长耗时任务，可调用标准模块中的主过程。

14. UserForm 用户窗体

14.1 创建筛选窗体

1. VBE 执行插入 → UserForm，Name 改为 frmSalesFilter，Caption 改为“销售筛选”。

2. 添加 ComboBox：

cboRegion。
TextBox：txtMinAmount。
CommandButton：cmdApply（筛选）。
CommandButton：cmdClose（关闭）。

3. 双击窗体，写初始化；双击按钮，写点击事件。

Option Explicit

Private Sub UserForm_Initialize()
    With Me.cboRegion
        .Clear
        .AddItem "全部"
        .AddItem "华东"
        .AddItem "华南"
        .AddItem "华北"
        .ListIndex = 0
    End With
    Me.txtMinAmount.Value = "0"
End Sub

Private Sub cmdApply_Click()
    Dim ws As Worksheet, region As String, minAmount As Double
    Set ws = ThisWorkbook.Worksheets("销售明细")
    region = Me.cboRegion.Value
    If Not IsNumeric(Me.txtMinAmount.Value) Then
        MsgBox "最低金额必须为数字。", vbExclamation
        Me.txtMinAmount.SetFocus
        Exit Sub
    End If
    minAmount = CDbl(Me.txtMinAmount.Value)

    If ws.AutoFilterMode Then ws.AutoFilterMode = False
    With ws.Range("A1").CurrentRegion
        .AutoFilter Field:=6, Criteria1:=">=" & minAmount
        If region <> "全部" Then .AutoFilter Field:=2, Criteria1:=region
    End With
    Unload Me
End Sub

Private Sub cmdClose_Click()
    Unload Me
End Sub

标准模块中打开：

Public Sub 显示筛选窗体()
    frmSalesFilter.Show
End Sub

故障排查：控件名与代码不一致会报“找不到方法或数据成员”；金额使用本地小数点，复杂地区格式应另写转换；筛选列序号按筛选区域内部相对位置计算。

15. 调试技术

F8：逐语句执行；Shift+F8：逐过程；F5：继续运行。
单击代码左侧灰边设置断点；条件断点可在循环内配合 If i=100 Then Stop。
悬停变量查看值；本地窗口查看当前过程全部变量；监视窗口观察表达式。
立即窗口：?变量、?ActiveCell.Address，也可执行赋值或调用过程。
Debug.Print 输出关键状态；Debug.Assert condition 在条件为 False 时中断。
Err.Raise vbObjectError + 1001, "过程名", "业务错误说明" 主动报告业务异常。

Public Sub 调试示例()
    Dim i As Long, total As Double
    For i = 1 To 10
        total = total + i
        Debug.Print "i="; i; " total="; total
        Debug.Assert total >= 0
    Next i
End Sub

调试顺序：

先稳定复现。
缩小输入。
检查对象限定。
检查数据类型和边界。
查看错误号。
修复根因。
用正常、空表、异常值、最大数据量做回归测试。

16. 宏安全与交付

1. 默认禁用来自互联网的宏；仅启用可信来源。

2. 将受控模板目录设置为受信任位置，而非全局启用所有宏。

3. 企业发布时使用代码签名证书：VBE 工具 → 数字签名。代码修改后需重新签名。

4. 密码保护 VBA 工程只能防误看，不能视为强加密；不要在代码中硬编码密码、令牌或个人敏感信息。

5. 对文件删除、覆盖、发送、外部连接等高风险动作提供预览、确认、备份和日志。

6. 在代码中限定可处理目录和扩展名，拒绝路径穿越和意外系统目录。

7. 分发说明中写明 Excel 版本、信任步骤、输入格式、输出位置、恢复方法和责任边界。

8. 打开陌生 .xlsm 前先在受控环境扫描；不要因“内容看起来正常”就启用宏。

17. 综合实战一：销售看板自动生成

17.1 项目目标与成品结构

从“销售明细”读取订单，生成“区域汇总”“产品汇总”和“销售看板”。看板包含总销售额、订单数、平均订单额、目标达成率、区域柱形图和产品排行图。代码可重复执行，旧输出被安全刷新，不依赖当前选区。

17.2 示例数据

新建工作表“销售明细”，粘贴到 A1：

日期	区域	销售员	产品	数量	销售额	订单号
2026-01-05	华东	陈晨	键盘	12	1548	SO001
2026-01-08	华南	林琳	鼠标	20	1780	SO002
2026-01-12	华北	周杰	显示器	3	4797	SO003
2026-02-03	华东	陈晨	显示器	2	3198	SO004
2026-02-11	华南	黄敏	键盘	18	2322	SO005
2026-02-21	华北	周杰	鼠标	30	2670	SO006
2026-03-02	华东	孙悦	鼠标	25	2225	SO007
2026-03-09	华南	林琳	显示器	4	6396	SO008
2026-03-18	华北	赵强	键盘	15	1935	SO009
2026-04-06	华东	孙悦	显示器	5	7995	SO010
2026-04-14	华南	黄敏	鼠标	22	1958	SO011
2026-04-25	华北	赵强	显示器	2	3198	SO012

新建“参数”表：A1 为“年度目标”，B1 为 50000。

17.3 逐步操作

1. 核对表头必须依次为日期、区域、销售员、产品、数量、销售额、订单号。

2. 把日期列设置为日期，数量和销售额设置为数值；删除合并单元格和空白表头。

3. 插入标准模块，命名 modSalesDashboard，粘贴完整代码。

4. 执行调试 → 编译 VBAProject。

5. 回 Excel，按 Alt+F8，执行生成销售看板。

6. 可在“销售看板”插入形状，右键“指定宏”，选择该过程，作为刷新按钮。

17.4 完整代码

Option Explicit

Public Sub 生成销售看板()
    Dim wb As Workbook
    Dim wsData As Worksheet, wsRegion As Worksheet, wsProduct As Worksheet, wsDash As Worksheet
    Dim data As Variant, dictRegion As Object, dictProduct As Object
    Dim lastRow As Long, i As Long, region As String, product As String
    Dim amount As Double, total As Double, orderCount As Long, target As Double
    Dim oldCalc As XlCalculation, k As Variant, r As Long
    Dim ch As ChartObject

    On Error GoTo ErrHandler
    Set wb = ThisWorkbook
    Set wsData = wb.Worksheets("销售明细")
    Set wsRegion = GetOrCreateSheet(wb, "区域汇总")
    Set wsProduct = GetOrCreateSheet(wb, "产品汇总")
    Set wsDash = GetOrCreateSheet(wb, "销售看板")

    oldCalc = Application.Calculation
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual

    ValidateSalesHeaders wsData
    lastRow = wsData.Cells(wsData.Rows.Count, "A").End(xlUp).Row
    If lastRow < 2 Then Err.Raise vbObjectError + 2001, , "销售明细没有数据。"
    data = wsData.Range("A2:G" & lastRow).Value2

    Set dictRegion = CreateObject("Scripting.Dictionary")
    Set dictProduct = CreateObject("Scripting.Dictionary")
    dictRegion.CompareMode = vbTextCompare
    dictProduct.CompareMode = vbTextCompare

    For i = 1 To UBound(data, 1)
        region = Trim$(CStr(data(i, 2)))
        product = Trim$(CStr(data(i, 4)))
        If Len(region) = 0 Or Len(product) = 0 Then
            Err.Raise vbObjectError + 2002, , "第" & (i + 1) & "行区域或产品为空。"
        End If
        If Not IsNumeric(data(i, 6)) Then
            Err.Raise vbObjectError + 2003, , "第" & (i + 1) & "行销售额不是数值。"
        End If
        amount = CDbl(data(i, 6))
        If Not dictRegion.Exists(region) Then dictRegion.Add region, 0#
        If Not dictProduct.Exists(product) Then dictProduct.Add product, 0#
        dictRegion(region) = dictRegion(region) + amount
        dictProduct(product) = dictProduct(product) + amount
        total = total + amount
        orderCount = orderCount + 1
    Next i

    wsRegion.Cells.Clear
    wsRegion.Range("A1:B1").Value = Array("区域", "销售额")
    r = 2
    For Each k In dictRegion.Keys
        wsRegion.Cells(r, 1).Value = k
        wsRegion.Cells(r, 2).Value = dictRegion(k)
        r = r + 1
    Next k
    FormatSummary wsRegion, r - 1

    wsProduct.Cells.Clear
    wsProduct.Range("A1:B1").Value = Array("产品", "销售额")
    r = 2
    For Each k In dictProduct.Keys
        wsProduct.Cells(r, 1).Value = k
        wsProduct.Cells(r, 2).Value = dictProduct(k)
        r = r + 1
    Next k
    FormatSummary wsProduct, r - 1
    wsProduct.Range("A1:B" & r - 1).Sort Key1:=wsProduct.Range("B2"), Order1:=xlDescending, Header:=xlYes

    If IsNumeric(wb.Worksheets("参数").Range("B1").Value) Then
        target = CDbl(wb.Worksheets("参数").Range("B1").Value)
    Else
        Err.Raise vbObjectError + 2004, , "参数!B1 年度目标不是数值。"
    End If

    wsDash.Cells.Clear
    For Each ch In wsDash.ChartObjects
        ch.Delete
    Next ch
    With wsDash
        .Range("A1:H1").Merge
        .Range("A1").Value = "销售经营看板"
        .Range("A1").Font.Size = 20
        .Range("A1").Font.Bold = True
        .Range("A1").HorizontalAlignment = xlCenter
        .Range("A3:D3").Value = Array("总销售额", "订单数", "平均订单额", "目标达成率")
        .Range("A4").Value = total
        .Range("B4").Value = orderCount
        .Range("C4").Value = IIf(orderCount = 0, 0, total / orderCount)
        .Range("D4").Value = IIf(target = 0, 0, total / target)
        .Range("A4,C4").NumberFormat = "¥#,##0.00"
        .Range("D4").NumberFormat = "0.0%"
        With .Range("A3:D4")
            .Borders.LineStyle = xlContinuous
            .HorizontalAlignment = xlCenter
        End With
        .Range("A3:D3").Interior.Color = RGB(31, 78, 121)
        .Range("A3:D3").Font.Color = vbWhite
        .Columns("A:H").ColumnWidth = 14
    End With

    Set ch = wsDash.ChartObjects.Add(Left:=20, Top:=120, Width:=420, Height:=260)
    With ch.Chart
        .SetSourceData wsRegion.Range("A1:B" & dictRegion.Count + 1)
        .ChartType = xlColumnClustered
        .HasTitle = True
        .ChartTitle.Text = "区域销售额"
        .HasLegend = False
    End With

    Set ch = wsDash.ChartObjects.Add(Left:=460, Top:=120, Width:=420, Height:=260)
    With ch.Chart
        .SetSourceData wsProduct.Range("A1:B" & dictProduct.Count + 1)
        .ChartType = xlBarClustered
        .HasTitle = True
        .ChartTitle.Text = "产品销售排行"
        .HasLegend = False
    End With

    MsgBox "看板已生成。总销售额：" & Format$(total, "#,##0.00"), vbInformation

CleanExit:
    Application.Calculation = oldCalc
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    Exit Sub
ErrHandler:
    MsgBox "生成销售看板失败：" & Err.Description, vbCritical
    Resume CleanExit
End Sub

Private Sub ValidateSalesHeaders(ByVal ws As Worksheet)
    Dim expected As Variant, i As Long
    expected = Array("日期", "区域", "销售员", "产品", "数量", "销售额", "订单号")
    For i = 0 To UBound(expected)
        If Trim$(CStr(ws.Cells(1, i + 1).Value)) <> expected(i) Then
            Err.Raise vbObjectError + 2010, , "第" & (i + 1) & "列表头应为“" & expected(i) & "”。"
        End If
    Next i
End Sub

Private Function GetOrCreateSheet(ByVal wb As Workbook, ByVal sheetName As String) As Worksheet
    On Error Resume Next
    Set GetOrCreateSheet = wb.Worksheets(sheetName)
    On Error GoTo 0
    If GetOrCreateSheet Is Nothing Then
        Set GetOrCreateSheet = wb.Worksheets.Add(After:=wb.Worksheets(wb.Worksheets.Count))
        GetOrCreateSheet.Name = sheetName
    End If
End Function

Private Sub FormatSummary(ByVal ws As Worksheet, ByVal lastRow As Long)
    With ws.Range("A1:B" & lastRow)
        .Borders.LineStyle = xlContinuous
        .Columns(2).NumberFormat = "¥#,##0.00"
        .EntireColumn.AutoFit
    End With
    With ws.Range("A1:B1")
        .Font.Bold = True
        .Font.Color = vbWhite
        .Interior.Color = RGB(31, 78, 121)
    End With
End Sub

17.5 结果检查

示例数据总销售额应为 40022。同时可用 Excel 公式独立复核。
可用 =SUM(销售明细!F2:F13) 与看板 A4 对照，两者必须一致。订单数应为 12。
平均订单额等于总额/12。
区域汇总之和与产品汇总之和都必须等于总额。再次运行后不应重复增加图表或汇总行。

手工校验：1548+1780+4797+3198+2322+2670+2225+6396+1935+7995+1958+3198 = 40022，因此看板总销售额应为 40022，平均订单额约 3335.17，目标达成率 80.044%。

17.6 故障排查

“下标越界”：工作表名称不一致，检查空格和全角字符。
图表空白：汇总表数据不是数值，或 SetSourceData 范围错误。
日期显示为序号：Value2 正常保存日期序列，给日期列设置格式即可。
第二次运行报合并单元格错误：Cells.Clear 不会取消合并；在清空前可加 wsDash.Cells.UnMerge。
达成率异常：目标为文本或单位不同；检查参数 B1 是否为纯数值且同为元。
编译提示过程重复：项目里已有同名 GetOrCreateSheet；统一放到工具模块并设为 Public，或改名。

17.7 练习与答案

1. 练习：增加“最高区域”指标。

2. 练习：只统计 2026 年第一季度。

3. 练习：刷新后保留用户在看板上的按钮。

4. 练习：区域汇总按金额降序。

18. 综合实战二：财务预算敏感性分析

18.1 项目目标

建立基础预算，并对“销量变化率”和“单价变化率”进行二维敏感性计算，输出收入、成本、利润、利润率以及不同情景下的利润矩阵，同时用颜色标出亏损与高利润情景。本项目不依赖工作表“模拟运算表”命令，而用 VBA 可控地批量计算。

18.2 示例数据

新建“预算模型”，粘贴到 A1：

参数	数值
基础销量	10000
基础单价	120
单位变动成本	72
固定成本	280000
税率	25%

新建“敏感性”，在 B2:F2 输入单价变化率 -10%,-5%,0%,5%,10%；在 A3:A7 输入销量变化率 -20%,-10%,0%,10%,20%。

模型定义：

调整后销量 = 基础销量 × (1 + 销量变化率)
调整后单价 = 基础单价 × (1 + 单价变化率)
收入 = 调整后销量 × 调整后单价
变动成本 = 调整后销量 × 单位变动成本
税前利润 = 收入 − 变动成本 − 固定成本
税后利润 = 若税前利润大于 0，则税前利润 × (1 − 税率)，否则保持亏损（简化假设，不确认递延所得税资产）

18.3 逐步操作

1. 确保百分比是真正数值，如 25% 等于 0.25。

2. 插入模块 modBudgetSensitivity，粘贴代码。

3. 先执行计算基础预算，检查“预算结果”。

4. 再执行生成敏感性矩阵。

5. 用矩阵中心（销量 0%、单价 0%）和基础税后利润核对。

6. 修改固定成本或税率后重新运行，观察矩阵变化。

18.4 完整代码

Option Explicit

Private Type BudgetInputs
    BaseVolume As Double
    BasePrice As Double
    UnitVariableCost As Double
    FixedCost As Double
    TaxRate As Double
End Type

Public Sub 计算基础预算()
    Dim p As BudgetInputs, result As Variant
    On Error GoTo ErrHandler
    p = ReadBudgetInputs(ThisWorkbook.Worksheets("预算模型"))
    result = CalculateScenario(p, 0, 0)
    WriteBudgetResult ThisWorkbook.Worksheets("预算结果"), result
    MsgBox "基础预算已计算。", vbInformation
    Exit Sub
ErrHandler:
    MsgBox "计算失败：" & Err.Description, vbCritical
End Sub

Public Sub 生成敏感性矩阵()
    Dim p As BudgetInputs, ws As Worksheet
    Dim rowLast As Long, colLast As Long, r As Long, c As Long
    Dim volumeChange As Double, priceChange As Double, result As Variant
    Dim oldCalc As XlCalculation
    On Error GoTo ErrHandler

    oldCalc = Application.Calculation
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

    p = ReadBudgetInputs(ThisWorkbook.Worksheets("预算模型"))
    Set ws = ThisWorkbook.Worksheets("敏感性")
    rowLast = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    colLast = ws.Cells(2, ws.Columns.Count).End(xlToLeft).Column
    If rowLast < 3 Or colLast < 2 Then Err.Raise vbObjectError + 3001, , "敏感性行列参数不完整。"

    ws.Range("A2").Value = "销量\单价"
    For r = 3 To rowLast
        If Not IsNumeric(ws.Cells(r, 1).Value) Then Err.Raise vbObjectError + 3002, , "A" & r & "不是数值百分比。"
        volumeChange = CDbl(ws.Cells(r, 1).Value)
        For c = 2 To colLast
            If Not IsNumeric(ws.Cells(2, c).Value) Then Err.Raise vbObjectError + 3003, , ws.Cells(2, c).Address & "不是数值百分比。"
            priceChange = CDbl(ws.Cells(2, c).Value)
            result = CalculateScenario(p, volumeChange, priceChange)
            ws.Cells(r, c).Value = result(6)  '税后利润
        Next c
    Next r

    With ws.Range(ws.Cells(3, 2), ws.Cells(rowLast, colLast))
        .NumberFormat = "¥#,##0;[Red]-¥#,##0"
        .FormatConditions.Delete
        .FormatConditions.AddColorScale ColorScaleType:=3
        With .FormatConditions(1)
            .ColorScaleCriteria(1).Type = xlConditionValueLowestValue
            .ColorScaleCriteria(1).FormatColor.Color = RGB(248, 105, 107)
            .ColorScaleCriteria(2).Type = xlConditionValuePercentile
            .ColorScaleCriteria(2).Value = 50
            .ColorScaleCriteria(2).FormatColor.Color = RGB(255, 235, 132)
            .ColorScaleCriteria(3).Type = xlConditionValueHighestValue
            .ColorScaleCriteria(3).FormatColor.Color = RGB(99, 190, 123)
        End With
        .Borders.LineStyle = xlContinuous
    End With
    ws.Range(ws.Cells(2, 2), ws.Cells(2, colLast)).NumberFormat = "0%"
    ws.Range(ws.Cells(3, 1), ws.Cells(rowLast, 1)).NumberFormat = "0%"
    ws.Columns.AutoFit
    MsgBox "敏感性矩阵已生成。", vbInformation

CleanExit:
    Application.Calculation = oldCalc
    Application.ScreenUpdating = True
    Exit Sub
ErrHandler:
    MsgBox "敏感性分析失败：" & Err.Description, vbCritical
    Resume CleanExit
End Sub

Private Function ReadBudgetInputs(ByVal ws As Worksheet) As BudgetInputs
    Dim p As BudgetInputs
    p.BaseVolume = RequireNumber(ws.Range("B2"), "基础销量")
    p.BasePrice = RequireNumber(ws.Range("B3"), "基础单价")
    p.UnitVariableCost = RequireNumber(ws.Range("B4"), "单位变动成本")
    p.FixedCost = RequireNumber(ws.Range("B5"), "固定成本")
    p.TaxRate = RequireNumber(ws.Range("B6"), "税率")
    If p.BaseVolume < 0 Or p.BasePrice < 0 Or p.UnitVariableCost < 0 Or p.FixedCost < 0 Then
        Err.Raise vbObjectError + 3010, , "销量、价格和成本不得为负数。"
    End If
    If p.TaxRate < 0 Or p.TaxRate > 1 Then Err.Raise vbObjectError + 3011, , "税率必须在0到100%之间。"
    ReadBudgetInputs = p
End Function

Private Function RequireNumber(ByVal cell As Range, ByVal label As String) As Double
    If IsError(cell.Value) Or Not IsNumeric(cell.Value) Then
        Err.Raise vbObjectError + 3020, , label & "（" & cell.Address(False, False) & "）必须为数值。"
    End If
    RequireNumber = CDbl(cell.Value)
End Function

Private Function CalculateScenario(ByVal p As BudgetInputs, ByVal volumeChange As Double, ByVal priceChange As Double) As Variant
    Dim volume As Double, price As Double, revenue As Double
    Dim variableCost As Double, pretaxProfit As Double, afterTaxProfit As Double, margin As Double
    volume = p.BaseVolume * (1 + volumeChange)
    price = p.BasePrice * (1 + priceChange)
    If volume < 0 Or price < 0 Then Err.Raise vbObjectError + 3030, , "变化率导致销量或单价为负。"
    revenue = volume * price
    variableCost = volume * p.UnitVariableCost
    pretaxProfit = revenue - variableCost - p.FixedCost
    If pretaxProfit > 0 Then
        afterTaxProfit = pretaxProfit * (1 - p.TaxRate)
    Else
        afterTaxProfit = pretaxProfit
    End If
    If revenue <> 0 Then margin = afterTaxProfit / revenue
    CalculateScenario = Array(volume, price, revenue, variableCost, p.FixedCost, pretaxProfit, afterTaxProfit, margin)
End Function

Private Sub WriteBudgetResult(ByVal ws As Worksheet, ByVal result As Variant)
    ws.Cells.Clear
    ws.Range("A1:B1").Value = Array("指标", "结果")
    ws.Range("A2:A9").Value = Application.Transpose(Array("调整后销量", "调整后单价", "收入", "变动成本", "固定成本", "税前利润", "税后利润", "税后利润率"))
    ws.Range("B2:B9").Value = Application.Transpose(result)
    ws.Range("B2").NumberFormat = "#,##0"
    ws.Range("B3:B8").NumberFormat = "¥#,##0.00;[Red]-¥#,##0.00"
    ws.Range("B9").NumberFormat = "0.00%"
    ws.Range("A1:B9").Borders.LineStyle = xlContinuous
    ws.Range("A1:B1").Font.Bold = True
    ws.Range("A1:B1").Interior.Color = RGB(31, 78, 121)
    ws.Range("A1:B1").Font.Color = vbWhite
    ws.Columns("A:B").AutoFit
End Sub

18.5 结果检查

基础销量 10000、单价 120：

收入 1,200,000。
变动成本 720,000。
固定成本 280,000。
税前利润 200,000。
税后利润 150,000。
税后利润率 12.5%。敏感性矩阵中心单元格应为 150,000。销量 -20%、单价 -10% 时：收入 864,000，变动成本 576,000，税前利润 8,000，税后利润 6,000。

18.6 故障排查

中心值不等于基础值：行列标题可能输入为文本“0% ”或矩阵起始位置错误。
百分比输入 25 而非 25%：税率会超出 1，程序会主动报错。
预算结果不存在：示例假设已创建该表；可复用前一项目的 GetOrCreateSheet。
亏损被错误乘税后系数：本代码明确只对正利润计税。
类型定义编译错误：确认 Type 声明在模块顶部、任何过程之外。
条件格式添加失败：旧版本可删除三色刻度部分，核心数值仍会生成。

18.7 练习与答案

1. 练习：增加原材料成本变化率为第三维。

2. 练习：求盈亏平衡销量。

3. 练习：将负利润设红色字体。

4. 练习：输出最差和最佳情景。

19. 综合实战三：批量汇总文件

19.1 项目目标与输入约定

从用户选择的文件夹读取所有 .xlsx、.xlsm、.xls 文件中名为“明细”的工作表，将统一字段追加到当前汇总工作簿的“总表”，增加“来源文件”和“来源行”两列，记录成功、跳过和失败日志。源工作簿只读打开，不更新链接，不运行其 Auto_Open 宏；处理完立即关闭。

每个源文件“明细”表 A1:F1 必须为：日期、区域、产品、数量、单价、金额。金额可为空，程序用数量×单价补算；若有金额则保留。

19.2 示例文件

在一个测试文件夹创建华东_01.xlsx、华南_01.xlsx，两者都有“明细”表。

华东_01.xlsx：

日期	区域	产品	数量	单价	金额
2026-01-03	华东	键盘	10	129	1290
2026-01-07	华东	鼠标	20	89	1780
2026-01-15	华东	显示器	2	1599	3198

华南_01.xlsx：

日期	区域	产品	数量	单价	金额
2026-01-05	华南	键盘	8	129	1032
2026-01-11	华南	鼠标	15	89	1335
2026-01-20	华南	显示器	3	1599	4797

另建汇总工作簿批量汇总工具.xlsm，创建“总表”和“运行日志”。不要把汇总工具放在待处理文件夹中；即便放入，代码也会按文件名排除自身。

19.3 逐步操作

1. 先复制测试文件，永远不要直接用唯一的生产文件测试。

2. 把完整代码放入标准模块 modBatchConsolidation。

3. 编译工程，保存 .xlsm。

4. 运行批量汇总明细，选择测试文件夹。

5. 程序先清空总表旧数据，再逐个读取，并在状态栏显示进度。

6. 检查总表记录数、金额合计、来源文件、日志。

7. 正式运行前用一个缺少“明细”表、一个表头错误、一个空文件验证错误隔离能力。

19.4 完整代码

Option Explicit

Public Sub 批量汇总明细()
    Dim folderPath As String, fileName As String, fullPath As String
    Dim wbSrc As Workbook, wsSrc As Worksheet, wsOut As Worksheet, wsLog As Worksheet
    Dim data As Variant, output() As Variant
    Dim lastRow As Long, outRow As Long, i As Long, j As Long, n As Long
    Dim successCount As Long, failCount As Long, skipCount As Long
    Dim oldCalc As XlCalculation, oldSecurity As MsoAutomationSecurity
    Dim oldEvents As Boolean, oldScreen As Boolean, oldAlerts As Boolean
    Dim oldStatus As Variant, exactOutput() As Variant, rr As Long, cc As Long

    oldCalc = Application.Calculation
    oldSecurity = Application.AutomationSecurity
    oldEvents = Application.EnableEvents
    oldScreen = Application.ScreenUpdating
    oldAlerts = Application.DisplayAlerts
    oldStatus = Application.StatusBar
    On Error GoTo FatalHandler
    folderPath = PickFolder()
    If Len(folderPath) = 0 Then Exit Sub

    Set wsOut = ThisWorkbook.Worksheets("总表")
    Set wsLog = ThisWorkbook.Worksheets("运行日志")
    PrepareOutput wsOut
    PrepareLog wsLog
    outRow = 2

    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.DisplayAlerts = False
    Application.Calculation = xlCalculationManual
    Application.AutomationSecurity = msoAutomationSecurityForceDisable

    fileName = Dir(folderPath & Application.PathSeparator & "*.xls*")
    Do While Len(fileName) > 0
        fullPath = folderPath & Application.PathSeparator & fileName
        Application.StatusBar = "正在处理：" & fileName

        If Left$(fileName, 2) = "~$" Or StrComp(fileName, ThisWorkbook.Name, vbTextCompare) = 0 Then
            skipCount = skipCount + 1
            AppendLog wsLog, fileName, "跳过", "临时文件或汇总工具自身"
            GoTo NextFile
        End If

        Set wbSrc = Nothing
        Set wsSrc = Nothing
        On Error GoTo FileError
        Set wbSrc = Workbooks.Open(Filename:=fullPath, UpdateLinks:=0, ReadOnly:=True, _
                                   AddToMru:=False, Notify:=False)
        Set wsSrc = Nothing
        On Error Resume Next
        Set wsSrc = wbSrc.Worksheets("明细")
        On Error GoTo FileError
        If wsSrc Is Nothing Then Err.Raise vbObjectError + 4001, , "缺少“明细”工作表"

        ValidateSourceHeaders wsSrc
        lastRow = wsSrc.Cells(wsSrc.Rows.Count, "A").End(xlUp).Row
        If lastRow < 2 Then
            skipCount = skipCount + 1
            AppendLog wsLog, fileName, "跳过", "没有数据行"
            wbSrc.Close SaveChanges:=False
            Set wbSrc = Nothing
            GoTo NextFile
        End If

        data = wsSrc.Range("A2:F" & lastRow).Value2
        ReDim output(1 To UBound(data, 1), 1 To 8)
        n = 0
        For i = 1 To UBound(data, 1)
            If Application.WorksheetFunction.CountA(wsSrc.Range("A" & i + 1 & ":F" & i + 1)) > 0 Then
                n = n + 1
                For j = 1 To 6
                    output(n, j) = data(i, j)
                Next j
                If (IsEmpty(output(n, 6)) Or Len(CStr(output(n, 6))) = 0) And _
                   IsNumeric(output(n, 4)) And IsNumeric(output(n, 5)) Then
                    output(n, 6) = CDbl(output(n, 4)) * CDbl(output(n, 5))
                End If
                output(n, 7) = fileName
                output(n, 8) = i + 1
            End If
        Next i

        If n > 0 Then
            If outRow + n - 1 > wsOut.Rows.Count Then Err.Raise vbObjectError + 4011, , "总表行数超出工作表上限"
            ReDim exactOutput(1 To n, 1 To 8)
            For rr = 1 To n
                For cc = 1 To 8
                    exactOutput(rr, cc) = output(rr, cc)
                Next cc
            Next rr
            wsOut.Cells(outRow, 1).Resize(n, 8).Value = exactOutput
            outRow = outRow + n
        End If
        successCount = successCount + 1
        AppendLog wsLog, fileName, "成功", "导入" & n & "行"
        wbSrc.Close SaveChanges:=False
        Set wbSrc = Nothing
        On Error GoTo FatalHandler
        GoTo NextFile

FileError:
        failCount = failCount + 1
        AppendLog wsLog, fileName, "失败", "错误" & Err.Number & "：" & Err.Description
        Resume FileCleanup

FileCleanup:
        On Error Resume Next
        If Not wbSrc Is Nothing Then wbSrc.Close SaveChanges:=False
        Set wbSrc = Nothing

NextFile:
        On Error GoTo FatalHandler
        fileName = Dir()
    Loop

    FormatOutput wsOut, outRow - 1
    MsgBox "批量汇总完成。" & vbCrLf & _
           "成功文件：" & successCount & vbCrLf & _
           "跳过文件：" & skipCount & vbCrLf & _
           "失败文件：" & failCount & vbCrLf & _
           "总数据行：" & (outRow - 2), vbInformation

CleanExit:
    On Error Resume Next
    If Not wbSrc Is Nothing Then wbSrc.Close SaveChanges:=False
    Application.AutomationSecurity = oldSecurity
    Application.Calculation = oldCalc
    Application.DisplayAlerts = oldAlerts
    Application.EnableEvents = oldEvents
    Application.ScreenUpdating = oldScreen
    Application.StatusBar = oldStatus
    Exit Sub

FatalHandler:
    MsgBox "汇总任务意外中止：" & Err.Number & " - " & Err.Description, vbCritical
    Resume CleanExit
End Sub

Private Function PickFolder() As String
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "选择源文件夹"
        .AllowMultiSelect = False
        If .Show = -1 Then PickFolder = .SelectedItems(1)
    End With
End Function

Private Sub PrepareOutput(ByVal ws As Worksheet)
    ws.Cells.Clear
    ws.Range("A1:H1").Value = Array("日期", "区域", "产品", "数量", "单价", "金额", "来源文件", "来源行")
End Sub

Private Sub PrepareLog(ByVal ws As Worksheet)
    ws.Cells.Clear
    ws.Range("A1:D1").Value = Array("时间", "文件", "状态", "说明")
End Sub

Private Sub AppendLog(ByVal ws As Worksheet, ByVal fileName As String, ByVal status As String, ByVal message As String)
    Dim r As Long
    r = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row + 1
    ws.Cells(r, 1).Resize(1, 4).Value = Array(Now, fileName, status, message)
End Sub

Private Sub ValidateSourceHeaders(ByVal ws As Worksheet)
    Dim expected As Variant, i As Long, actual As String
    expected = Array("日期", "区域", "产品", "数量", "单价", "金额")
    For i = 0 To UBound(expected)
        actual = Trim$(CStr(ws.Cells(1, i + 1).Value))
        If actual <> expected(i) Then
            Err.Raise vbObjectError + 4010, , "表头错误：" & ws.Cells(1, i + 1).Address(False, False) & _
                " 应为“" & expected(i) & "”，实际为“" & actual & "”"
        End If
    Next i
End Sub

Private Sub FormatOutput(ByVal ws As Worksheet, ByVal lastRow As Long)
    If lastRow < 1 Then Exit Sub
    With ws.Range("A1:H" & lastRow)
        .Borders.LineStyle = xlContinuous
        .Rows(1).Font.Bold = True
        .Rows(1).Font.Color = vbWhite
        .Rows(1).Interior.Color = RGB(31, 78, 121)
    End With
    If lastRow >= 2 Then
        ws.Range("A2:A" & lastRow).NumberFormat = "yyyy-mm-dd"
        ws.Range("D2:D" & lastRow).NumberFormat = "#,##0"
        ws.Range("E2:F" & lastRow).NumberFormat = "¥#,##0.00"
    End If
    ws.Columns("A:H").AutoFit
    ws.Range("A1:H1").AutoFilter
End Sub

19.5 重要代码审查说明

主程序已按有效行数建立 exactOutput 数组，避免输出区域和数组尺寸不一致。遇到单个文件错误时，用 Resume 离开当前错误处理状态，再关闭源文件并继续；任务结束时恢复进入宏前的计算、事件、提示和屏幕刷新设置。运行前仍应备份“总表”和“运行日志”，因为程序会清空这两张表。

Dir 枚举期间不要在被调用过程内再次调用 Dir，以免重置文件枚举。示例以 A 列日期确定最后一行，因此每条有效明细的 A 列必须有值；若业务允许日期空白，应改用 Find 定位 A:F 的最后一个数据单元格。仅对可信测试文件运行，禁用宏并不能隔离所有外部连接或 Excel 4.0 宏风险。

19.6 结果检查

两份示例文件应导入 6 行；金额合计：1290+1780+3198+1032+1335+4797 = 13432。来源文件分别出现 3 次，来源行应为 2、3、4。运行日志应有两条“成功”，失败数为 0。源文件最后修改时间不应因只读打开而改变。再次运行会先清空总表，因此仍是 6 行而非 12 行。

19.7 故障排查

文件仍被占用：源文件可能由他人独占打开；日志会记录失败，关闭占用后重跑。
密码文件弹窗：Workbooks.Open 需要 Password 参数；不要把密码硬编码在公开代码里。
合计差异：检查金额是否为文本、是否有空行、数量单价是否含货币符号。
宏安全提示：代码把自动化打开的源宏强制禁用，并在清理段恢复原设置。
找不到明细表：检查名称是否有尾随空格；可改成遍历表名并 Trim 比较。
运行中止后界面不刷新：立即窗口恢复 ScreenUpdating、EnableEvents、DisplayAlerts、Calculation。
文件很多时慢：避免复制粘贴和逐格写入；当前代码已使用数组。进一步可按文件累计到大数组，再一次写入。
日期混乱：Value2 保存日期序列；若源是文本日期，应在导入时用 IsDate/CDate 标准化并记录失败行。

19.8 练习与答案

1. 练习：追加模式，不清空旧记录，同时避免重复导入。

2. 练习：处理所有工作表而不只“明细”。

3. 练习：只导入 2026 年记录。

4. 练习：保存总表为独立 xlsx。

5. 练习：显示百分比进度。

20. 综合验收清单

20.1 功能验收

[ ] 所有模块都含 Option Explicit，并可通过“调试 → 编译”。
[ ] 代码不依赖选择、激活和活动工作簿。
[ ] 输入表头、空数据、非数值、日期和路径均有校验。
[ ] 正常输入结果与手工公式一致。
[ ] 重复执行不会重复追加图表、格式或汇总数据，除非设计为追加模式。
[ ] 每个打开的源工作簿在成功和失败路径都能关闭。
[ ] 性能状态与安全状态在错误后恢复。
[ ] 日志足以定位文件、过程、行和错误说明。

20.2 边界测试

至少测试：

只有表头的空表。
一行数据。
一万行数据。
空白行。
重复订单。
金额为 0。
负数。
错误值 #N/A。
文本数字。
日期文本。
缺少工作表。
表头拼错。
只读文件。
被占用文件。
路径含中文和空格。
工作簿中有事件程序。
用户中途取消文件夹选择。

20.3 代码质量验收

一个过程只承担一个主要职责；重复逻辑抽成函数。
变量名表达业务含义，不使用大量 a、b、x。
常量代替散落的魔法数字和表名。
对象变量显式 Set，Range/Cells 完整限定父对象。
错误处理不滥用 Resume Next。
注释解释“为什么”，而非逐字复述代码。
高风险动作有备份、预览、确认和日志。

21. 章节综合练习与参考答案

练习 1：最后一行策略

某表 A 列允许为空，F 列公式可能返回空字符串。要求得到真正包含常量或公式的最后行。

练习 2：性能改写

原程序循环十万行，每格读取数量和单价并写金额。

练习 3：事件递归

Worksheet_Change 中把输入转大写，Excel 卡死。

练习 4：字典复合键

按“区域+产品”汇总。

练习 5：错误继续

批处理某个文件损坏时应继续下一个。

练习 6：ThisWorkbook 与 ActiveWorkbook

加载项中的宏处理用户当前文件应使用哪一个？

练习 7：安全删除

删除所有空白工作表。

参考答案：

先生成预览名单。
至少保留一张可见表。
取得确认后关闭 DisplayAlerts 删除。
无论成功失败都恢复 DisplayAlerts，并写日志。

练习 8：UserForm 验证

金额文本框允许空、数字，但不允许负数。

练习 9：Select Case

把订单金额分为 0、1~999、1000~9999、10000以上。

练习 10：动态数组边界

空表时 Range("A2:A" & lastRow) 变成 A2:A1。

22. 学习路线建议

第一阶段先录制宏、认识 VBE 和对象限定。
第二阶段掌握变量、分支、循环、Range 和最后一行。
第三阶段学习数组、字典、错误处理和性能框架。
第四阶段处理事件、窗体与文件批处理。
第五阶段独立重构三个实战项目。每完成一个阶段，都应做到：能解释代码、能从空白重写关键段、能构造异常数据、能用断点定位错误，并能独立重写关键代码。

建议把三个项目分别复制一份进行改造：销售看板增加月份筛选和目标线；预算模型增加成本变化第三维；批量汇总增加去重和增量模式。每次改动先写验收结果，再写代码。自动化的验收项目包括结果正确、失败可见、过程可追溯、重复执行稳定且风险可控。

23. 教师与自学者的代码评审量表

每个练习按100 分评分：

结果正确30 分。
对象限定与类型选择15 分。
异常和空数据处理15 分。
重复执行稳定性10 分。
性能10 分。
安全与可恢复性10 分。
命名、注释和模块职责10 分。低于六10 分意味着代码可能“碰巧能跑”但不能交付。评审时应要求学习者现场解释一处对象限定、一处边界判断、一处错误恢复和一项结果校验。

优秀答案应做到：

输入契约写在过程前。
表名和关键列不散落在多处。
不使用无边界的Resume Next。
不靠Select和Activate驱动业务。
打开的文件始终关闭。
宏状态始终恢复。
输出包含来源和运行时间。
示例数据的手算结果与程序一致。若代码速度很快但可能写错工作簿，仍判定为不合格。

24. 最终交付演练

选择前三个项目之一，把它交给一位没有参与编写的人。只提供工作簿和一页使用说明，让对方完成导入、运行、检查和恢复。记录对方在哪一步犹豫、输入了什么异常内容、是否能理解错误消息。根据观察修改按钮名称、参数提示、日志字段和输入校验。最后冻结一个测试数据副本，保存预期总行数、总金额、分组结果和运行日志，以后每次改代码都重新执行回归测试。

达到本模块的验收标准，需要做到四点：

输入规则明确。
程序可重复运行。
错误能通过日志定位。
高风险操作可以预览、取消并恢复。满足这四点后，VBA程序才适合交付给他人使用。