基于单元格值复制删除工作表的VBA代码误删问题求助

以下是修改后的VBA代码，可避免误删指定的自定义工作表（如Sheet8），并按你要求的顺序排列最终工作表：

Sub ManageSheets()
    Dim ws As Worksheet
    Dim targetNamesRange As Range
    Dim targetName As Variant
    Dim permanentSheets As Variant
    Dim allowedSheets As Collection
    Dim desiredOrder As Variant
    Dim i As Integer
    
    ' 定义永久保留的工作表名称（包括不能删除的自定义表）
    permanentSheets = Array("1", "2", "3", "4", "5", "6", "6.1", "8")
    
    ' 定义目标工作表名称的来源区域（请根据实际情况修改工作表和范围）
    Set targetNamesRange = ThisWorkbook.Sheets("Sheet1").Range("A1:E2") ' 示例范围，自行调整
    
    ' 创建允许存在的工作表集合：永久保留 + 目标单元格值
    Set allowedSheets = New Collection
    ' 添加永久保留的表
    For Each targetName In permanentSheets
        On Error Resume Next
        allowedSheets.Add targetName, Key:=targetName
        On Error GoTo 0
    Next
    ' 添加目标单元格中的表名
    For Each targetName In targetNamesRange
        If targetName.Value <> "" Then
            On Error Resume Next
            allowedSheets.Add CStr(targetName.Value), Key:=CStr(targetName.Value)
            On Error GoTo 0
        End If
    Next
    
    ' 删除不在允许列表中的工作表
    Application.DisplayAlerts = False
    For Each ws In ThisWorkbook.Sheets
        On Error Resume Next
        allowedSheets.Item(ws.Name)
        If Err.Number <> 0 Then
            ws.Delete
        End If
        On Error GoTo 0
    Next
    Application.DisplayAlerts = True
    
    ' 复制Sheet6.1生成目标工作表（如果不存在）
    For Each targetName In targetNamesRange
        If targetName.Value <> "" Then
            Dim targetSheetName As String
            targetSheetName = CStr(targetName.Value)
            On Error Resume Next
            Set ws = ThisWorkbook.Sheets(targetSheetName)
            If Err.Number <> 0 Then
                ' 复制Sheet6.1并重命名
                ThisWorkbook.Sheets("6.1").Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
                ActiveSheet.Name = targetSheetName
            End If
            On Error GoTo 0
        End If
    Next
    
    ' 按照指定顺序排列工作表
    desiredOrder = Array("1", "2", "3", "4", "5", "6", "6.1", "A1", "A2", "B1", "C1", "D1", "D2", "E1", "8")
    For i = LBound(desiredOrder) To UBound(desiredOrder)
        On Error Resume Next
        Set ws = ThisWorkbook.Sheets(desiredOrder(i))
        If Err.Number = 0 Then
            If i = 0 Then
                ws.Move Before:=ThisWorkbook.Sheets(1)
            Else
                ws.Move After:=ThisWorkbook.Sheets(i)
            End If
        End If
        On Error GoTo 0
    Next
End Sub

关键修改说明 #

• 永久保留列表：通过permanentSheets数组指定不会被删除的工作表，包括你提到的Sheet8（名称为"8"，请根据实际工作表名称调整）。
• 允许集合：合并永久保留表和目标单元格生成的表名，确保只有这些表能保留。
• 排序逻辑：通过desiredOrder数组定义最终的工作表顺序，逐个调整位置。
• 错误处理：加入On Error Resume Next避免因表不存在导致的代码中断。

使用前请确认：

1. 目标单元格范围targetNamesRange是否符合你的实际数据位置。
2. permanentSheets和desiredOrder中的工作表名称与实际工作表完全一致（区分大小写）。

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