Excel工作簿运行工作表隐藏/取消隐藏VBA代码崩溃，求原因及优化方案

一、可能的崩溃成因 #

• 大量冗余的Select/Activate操作：代码中反复切换工作表、选中单元格，触发大量界面重绘，资源占用飙升，工作表数量较多时直接触发崩溃
• 错误处理逻辑缺失：仅在开头启用了On Error Resume Next未关闭，后续调用SpecialCells时如果目标区域无匹配内容（比如没有隐藏工作表）会直接抛出未处理错误，严重时引发内存溢出
• 密码不匹配：批量取消工作表保护时使用的密码是password，而Control表使用的保护密码是passwordhere，密码错误导致取消保护失败，后续操作触发异常
• 硬编码的等待逻辑不合理：Power Query刷新完成时间不固定，硬等2秒如果刷新未完成，后续的保护、隐藏工作表操作和刷新进程冲突，直接导致Excel崩溃
• 暴力终止进程：代码末尾使用End语句直接终止所有VBA进程，内存清理逻辑异常时会直接把Excel进程带崩
• 未禁用屏幕更新、事件触发：运行过程中屏幕持续重绘、其他事件被触发，额外占用大量系统资源
• 循环选中工作表的冗余操作：给所有工作表加保护时反复选中工作表、定位单元格，无意义操作过多容易卡死

二、优化方案及修改后代码 #

优化核心要点：

1. 全程禁用屏幕更新、自动重算、显示警报，运行结束后恢复
2. 移除所有Select/Activate操作，直接引用对象完成操作
3. 用数组存储初始隐藏的工作表名称，不依赖单元格存储避免读写错误
4. 统一保护密码，增加错误捕获逻辑，避免未处理错误导致崩溃
5. 移除无意义的等待语句，禁用查询的后台刷新保证同步执行
6. 去掉End语句，用正常流程退出即可
7. 避免SpecialCells的风险调用，提前判断是否有内容再操作

Private Sub Workbook_Open()
    Dim hiddenSheets As Collection
    Dim sht As Worksheet
    Dim link As Variant
    Dim conn As WorkbookConnection
    Dim i As Long
    
    ' 初始化运行环境
    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
        .Calculation = xlCalculationManual
        .EnableEvents = False
        .StatusBar = "正在准备刷新数据..."
    End With
    
    On Error GoTo ErrHandler ' 统一错误处理
    
    ' 处理Control表
    Set sht = ThisWorkbook.Sheets("Control")
    sht.Visible = xlSheetVisible
    sht.Unprotect Password:="passwordhere"
    
    ' 清空原有内容，无需选中操作
    sht.Range("T7").Value = "隐藏工作表:"
    With sht.Range("T7").Font
        .Bold = True
        .Underline = True
    End With
    sht.Range("T8:T5000").Clear
    sht.Range("T4:T5000").Clear ' 提前清空链接存储区域
    
    ' 收集初始隐藏的工作表，存入集合同时写入Control表
    Set hiddenSheets = New Collection
    i = 8
    For Each sht In ThisWorkbook.Sheets
        If sht.Visible = xlSheetHidden Then
            hiddenSheets.Add sht.Name
            ThisWorkbook.Sheets("Control").Cells(i, 20).Value = sht.Name
            i = i + 1
        End If
    Next sht
    
    ' 取消所有工作表隐藏，同时统一密码取消保护
    For Each sht In ThisWorkbook.Sheets
        sht.Visible = xlSheetVisible
        sht.Unprotect Password:="passwordhere"
        sht.Outline.ShowLevels RowLevels:=1
    Next sht
    
    ' 列出关联的外部工作簿
    Application.StatusBar = "正在读取外部链接..."
    If Not IsEmpty(ThisWorkbook.LinkSources(xlExcelLinks)) Then
        i = 4
        For Each link In ThisWorkbook.LinkSources(xlExcelLinks)
            If Not link Like "*Corporate Guidelines Master.xlsm" Then
                ThisWorkbook.Sheets("Control").Cells(i, 20).Value = link
                i = i + 1
            End If
        Next link
    End If
    
    ' 刷新Power Query，强制禁用后台刷新保证同步完成
    Application.StatusBar = "正在刷新数据..."
    Set conn = ThisWorkbook.Connections("Query - Consolidated")
    conn.OLEDBConnection.BackgroundQuery = False ' 强制关闭后台刷新，无需硬等
    conn.Refresh
    DoEvents ' 确保刷新完成后再执行后续操作
    
    ' 重新给所有工作表加保护
    Application.StatusBar = "正在重新保护工作表..."
    For Each sht In ThisWorkbook.Sheets
        sht.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True, _
            AllowFormattingColumns:=True, AllowFormattingRows:=True, _
            Password:="passwordhere"
    Next sht
    
    ' 隐藏绿色标签的工作表
    For Each sht In ThisWorkbook.Sheets
        If sht.Tab.Color = 4697456 Then
            sht.Visible = xlSheetHidden
        End If
    Next sht
    
    ' 隐藏初始的隐藏工作表
    For i = 1 To hiddenSheets.Count
        ThisWorkbook.Sheets(hiddenSheets(i)).Visible = xlSheetHidden
    Next i
    
    ' 收尾操作
    ThisWorkbook.Sheets("Control").Visible = xlSheetHidden
    ThisWorkbook.Sheets("Plant Summary Graphs").Activate
    ThisWorkbook.Sheets("Plant Summary Graphs").Range("A1").Select
    
ExitHandler:
    ' 恢复Excel默认设置
    With Application
        .ScreenUpdating = True
        .DisplayAlerts = True
        .Calculation = xlCalculationAutomatic
        .EnableEvents = True
        .StatusBar = False
    End With
    ' 释放对象内存
    Set hiddenSheets = Nothing
    Set sht = Nothing
    Set conn = Nothing
    Exit Sub
    
ErrHandler:
    MsgBox "运行出错：" & Err.Description, vbCritical
    Resume ExitHandler
End Sub

内容的提问来源于stack exchange，提问作者monica