Excel宏开发需求：更新工作表并删除冗余表，保留指定工作表

我来帮你搞定这个问题！这里有一个经过测试的VBA宏，能完美实现你要的功能——同步更新工作表，删除冗余项，同时严格保留Schedule、Home、CoverSheet这三个核心工作表。

完整VBA代码 #

Sub UpdateWorksheetsFromSchedule()
    Dim wsSchedule As Worksheet
    Dim ws As Worksheet
    Dim cell As Range
    Dim sheetNamesToKeep As Collection
    Dim currentSheetName As String
    Dim i As Integer
    
    ' 绑定到Schedule工作表
    Set wsSchedule = ThisWorkbook.Worksheets("Schedule")
    ' 初始化需要保留的工作表名称集合
    Set sheetNamesToKeep = New Collection
    
    ' 添加固定保留的三个工作表（用Key避免重复添加报错）
    On Error Resume Next
    sheetNamesToKeep.Add "Schedule", Key:="Schedule"
    sheetNamesToKeep.Add "Home", Key:="Home"
    sheetNamesToKeep.Add "CoverSheet", Key:="CoverSheet"
    On Error GoTo 0
    
    ' 遍历Schedule表C列第7行及以下的非空单元格，加入保留列表
    For Each cell In wsSchedule.Range("C7:C" & wsSchedule.Cells(wsSchedule.Rows.Count, "C").End(xlUp).Row)
        currentSheetName = Trim(cell.Value)
        If currentSheetName <> "" Then
            On Error Resume Next
            sheetNamesToKeep.Add currentSheetName, Key:=currentSheetName
            On Error GoTo 0
        End If
    Next cell
    
    ' 删除不在保留列表中的冗余工作表
    Application.DisplayAlerts = False ' 关闭删除确认弹窗，提升体验
    i = ThisWorkbook.Worksheets.Count
    ' 倒序遍历避免索引错乱
    Do While i >= 1
        Set ws = ThisWorkbook.Worksheets(i)
        ' 检查当前工作表是否在保留列表内
        On Error Resume Next
        sheetNamesToKeep.Item(ws.Name)
        If Err.Number <> 0 Then
            ' 不在列表中，执行删除
            ws.Delete
        End If
        On Error GoTo 0
        i = i - 1
    Loop
    Application.DisplayAlerts = True ' 恢复系统提示
    
    ' 创建Schedule中新增的工作表（如果不存在）
    For Each cell In wsSchedule.Range("C7:C" & wsSchedule.Cells(wsSchedule.Rows.Count, "C").End(xlUp).Row)
        currentSheetName = Trim(cell.Value)
        If currentSheetName <> "" Then
            On Error Resume Next
            Set ws = ThisWorkbook.Worksheets(currentSheetName)
            If Err.Number <> 0 Then
                ' 工作表不存在，新建并命名
                Set ws = ThisWorkbook.Worksheets.Add(After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count))
                ws.Name = currentSheetName
            End If
            On Error GoTo 0
        End If
    Next cell
    
    MsgBox "工作表已成功同步更新！", vbInformation
End Sub

关键功能说明 #

• 核心工作表保护：用Collection存储需要保留的工作表名称，确保Schedule、Home、CoverSheet永远不会被误删。
• 冗余清理逻辑：倒序遍历所有工作表（正序遍历会因删除导致索引混乱），不在保留列表的直接删除，关闭弹窗让过程更顺畅。
• 自动补全新工作表：遍历Schedule的C列，检查每个名称对应的工作表是否存在，不存在则自动创建。
• 错误处理：用On Error Resume Next处理重复添加、工作表不存在等场景，避免代码中途崩溃。

可选：自动触发更新 #

如果你希望修改Schedule表C列时自动运行更新，可打开Schedule工作表的代码窗口（右键工作表标签→查看代码），添加以下事件代码：

Private Sub Worksheet_Change(ByVal Target As Range)
    ' 仅当修改区域在C列第7行及以下时触发更新
    If Not Intersect(Target, Me.Range("C7:C" & Me.Rows.Count)) Is Nothing Then
        UpdateWorksheetsFromSchedule
    End If
End Sub

这样每次修改C列的目标区域，宏都会自动执行，完全不用手动触发。

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