Excel VBA创建工作表遇名称已存在错误，需实现跳过错误继续执行

问题背景 #

你编写了两个VBA宏：

1. 表格扩展宏：根据单元格D3的值扩展Table1表格并自动编号新行
2. 创建工作表宏：复制Template工作表，以Overview工作表B列的内容命名新表，填充数据并添加超链接

首次运行创建工作表宏一切正常，但扩展表格后再次运行时，会因目标工作表名称已存在弹出错误，导致宏中断，需要实现跳过重复名称、继续处理下一行的功能。

解决方案 #

方法1：添加错误捕获机制 #

在循环内添加错误捕获逻辑，遇到重复名称时跳过当前单元格处理，继续下一个循环：

Sub Create_worksheets()
    
    Dim rngCreateSheets As Range
    Dim oCell As Range
    Dim oTemplate As Worksheet
    Dim oSummary As Worksheet
    Dim oDest As Worksheet

    Set oTemplate = Worksheets("Template")
    Set oSummary = Worksheets("Overview")
    ' 限定工作表范围，避免因活动表切换导致的错误
    Set rngCreateSheets = oSummary.Range("B6", oSummary.Range("B6").End(xlDown))

    teller = 1
    For Each oCell In rngCreateSheets.Cells
        ' 跳过空单元格，避免无效工作表名称
        If Trim(oCell.Value) = "" Then GoTo NextCell
        
        ' 提前检查工作表是否已存在
        On Error Resume Next
        Set oDest = ThisWorkbook.Worksheets(oCell.Value)
        If Err.Number = 0 Then
            ' 工作表已存在，直接跳过创建步骤
            GoTo NextCell
        End If
        On Error GoTo 0
        
        ' 复制模板工作表
        oTemplate.Copy After:=Worksheets(Sheets.Count)
        Set oDest = ActiveSheet
        
        ' 尝试重命名，捕获名称重复错误
        On Error Resume Next
        oDest.Name = oCell.Value
        If Err.Number <> 0 Then
            ' 重命名失败，删除新建的空白工作表
            Application.DisplayAlerts = False
            oDest.Delete
            Application.DisplayAlerts = True
            GoTo NextCell
        End If
        On Error GoTo 0
        
        ' 填充工作表数据
        oDest.Range("C5").Value = oCell.Value
        oDest.Range("D2").Value = oSummary.Range("start_scenario").Offset(teller, 0).Value
        oDest.Range("B3").Value = oSummary.Range("start_scenario").Offset(teller, 1).Value
        oDest.Range("B4").Value = oSummary.Range("start_scenario").Offset(teller, 2).Value
        
        ' 添加超链接到Overview表
        oSummary.Hyperlinks.Add Anchor:=oCell, Address:="", SubAddress:= _
            oDest.Name & "!C5", TextToDisplay:=oDest.Name
        
NextCell:
        teller = teller + 1
    Next oCell
    
End Sub

关键修改点：

• 限定工作表范围：原代码中Range("B6").End(xlDown)未指定工作表，修改后避免因活动表切换导致的范围错误
• 提前检查工作表存在性：先尝试获取同名工作表，存在则直接跳过
• 错误捕获重命名操作：若复制后重命名失败，自动删除空白工作表并跳过当前循环
• 空单元格过滤：避免因B列空值生成无效工作表名称

方法2：预检查工作表是否存在（更稳妥） #

在复制模板前主动判断目标名称的工作表是否已存在，不存在才执行创建操作：

Sub Create_worksheets()
    
    Dim rngCreateSheets As Range
    Dim oCell As Range
    Dim oTemplate As Worksheet
    Dim oSummary As Worksheet
    Dim oDest As Worksheet
    Dim sheetExists As Boolean

    Set oTemplate = Worksheets("Template")
    Set oSummary = Worksheets("Overview")
    Set rngCreateSheets = oSummary.Range("B6", oSummary.Range("B6").End(xlDown))

    teller = 1
    For Each oCell In rngCreateSheets.Cells
        sheetExists = False
        If Trim(oCell.Value) = "" Then GoTo NextCell
        
        ' 遍历所有工作表检查名称是否重复
        For Each ws In ThisWorkbook.Worksheets
            If ws.Name = oCell.Value Then
                sheetExists = True
                Exit For
            End If
        Next ws
        
        If sheetExists Then
            ' 可选：为已存在的工作表更新超链接，保证链接有效性
            oSummary.Hyperlinks.Add Anchor:=oCell, Address:="", SubAddress:= _
                oCell.Value & "!C5", TextToDisplay:=oCell.Value
            GoTo NextCell
        End If
        
        ' 创建新工作表并配置
        oTemplate.Copy After:=Worksheets(Sheets.Count)
        Set oDest = ActiveSheet
        oDest.Name = oCell.Value
        
        oDest.Range("C5").Value = oCell.Value
        oDest.Range("D2").Value = oSummary.Range("start_scenario").Offset(teller, 0).Value
        oDest.Range("B3").Value = oSummary.Range("start_scenario").Offset(teller, 1).Value
        oDest.Range("B4").Value = oSummary.Range("start_scenario").Offset(teller, 2).Value
        
        oSummary.Hyperlinks.Add Anchor:=oCell, Address:="", SubAddress:= _
            oDest.Name & "!C5", TextToDisplay:=oDest.Name
        
NextCell:
        teller = teller + 1
    Next oCell
    
End Sub

优势：

• 主动检查避免错误触发，逻辑更清晰
• 可选择更新已存在工作表的超链接，保证链接有效性

额外优化：表格扩展宏的编号逻辑 #

原表格扩展宏每次都遍历所有行编号，可优化为仅对新增行编号，提升效率：

Sub Tableexpension()
    'Declare Variables
    Dim oSheetName As Worksheet
    Dim sTableName As String
    Dim loTable As ListObject
    Dim loRows As Integer
    Dim iNewRows As Integer
    Dim startRow As Long

    'Define Variable
    sTableName = "Table1"
    
    'Define WorkSheet object
    Set oSheetName = Sheets("Overview")
    
    'Define Table Object
    Set loTable = oSheetName.ListObjects(sTableName)
    
    'Find number of rows in the table
    loRows = loTable.ListRows.Count

    'Specify Number of Rows to add to table
    iNewRows = oSheetName.Range("D3").Value
    If iNewRows <= 0 Then Exit Sub ' 避免添加0或负数行
    
    'Resize the table
    loTable.Resize loTable.Range.Resize(loTable.Range.Rows.Count + iNewRows)
    
    'Number only new table rows
    startRow = loRows + 1
    If startRow <= loTable.ListRows.Count Then
        loTable.DataBodyRange(startRow, 1).Resize(loTable.ListRows.Count - startRow + 1).Value = _
            Application.WorksheetFunction.Transpose(Application.WorksheetFunction.Row(startRow To loTable.ListRows.Count))
    End If
End Sub

内容的提问来源于stack exchange，提问作者Mycha van Rossum