Excel VBA宏优化：重复工作表时创建替代名或删除原表

针对你需要宏重复执行时，即使目标工作表已存在仍能创建新表的需求，提供两种可行方案：

方案1：删除原工作表后重建 #

这个方案直接删除已存在的同名工作表，再重新创建并填充数据，适合需要覆盖旧数据的场景。

修改原代码中检测工作表存在的逻辑部分，替换原有的Else块内容：

' create sheet but check if already exists
On Error Resume Next
Set wsNew = Sheets(sName)
On Error GoTo 0

If wsNew Is Nothing Then
    ' ok add
    Set wsNew = Sheets.Add(after:=Sheets(Sheets.Count))
    wsNew.Name = sName
    MsgBox "The sheet has been successfully created. Wait a few seconds until Excel pastes the data from : " & wsNew.Name, vbInformation
Else
    ' 存在则删除原表，再新建
    MsgBox "Sheet '" & sName & "' already exists, will delete and rebuild it", vbExclamation, "Notice"
    ' 关闭删除工作表的警告提示
    Application.DisplayAlerts = False
    wsNew.Delete
    Application.DisplayAlerts = True
    ' 新建工作表
    Set wsNew = Sheets.Add(after:=Sheets(Sheets.Count))
    wsNew.Name = sName
End If

完整修改后的代码：

Option Explicit

Sub createsheet()

    Const COL_HA = 6 ' F on data sheet is Health Auth

    Dim sName As String, sId As String
    Dim wsNew As Worksheet, wsUser As Worksheet
    Dim wsIndex As Worksheet, wsData As Worksheet
    Dim rngName As Range, rngCopy As Range
    
    With ThisWorkbook
         Set wsUser = .Sheets("user")
         Set wsData = .Sheets("data")
         Set wsIndex = .Sheets("index")
    End With
         
    ' find row in index table for name from drop down
    sName = Left(wsUser.Range("M42").Value, 30)
    Set rngName = wsIndex.Range("L5:L32").Find(sName)
    If rngName Is Nothing Then
        MsgBox "Could not find " & sName & " on index sheet", vbCritical
        Exit Sub ' 找不到名称时直接退出，避免后续报错
    Else
        sId = rngName.Offset(, -1) ' column to left
    End If
    
    ' create sheet but check if already exists
    On Error Resume Next
    Set wsNew = Sheets(sName)
    On Error GoTo 0
    
    If wsNew Is Nothing Then
        ' ok add
        Set wsNew = Sheets.Add(after:=Sheets(Sheets.Count))
        wsNew.Name = sName
        MsgBox "The sheet has been successfully created. Wait a few seconds until Excel pastes the data from : " & wsNew.Name, vbInformation
    Else
        ' 存在则删除原表，再新建
        MsgBox "Sheet '" & sName & "' already exists, will delete and rebuild it", vbExclamation, "Notice"
        ' 关闭删除工作表的警告提示
        Application.DisplayAlerts = False
        wsNew.Delete
        Application.DisplayAlerts = True
        ' 新建工作表
        Set wsNew = Sheets.Add(after:=Sheets(Sheets.Count))
        wsNew.Name = sName
    End If
    
    ' filter sheet and copy data
    Dim lastrow As Long, rngData As Range
    With wsData
        lastrow = .Cells(.Rows.Count, COL_HA).End(xlUp).Row
        Set rngData = .Range("A10:Z" & lastrow)
        .AutoFilterMode = False
        rngData.AutoFilter Field:=COL_HA, Criteria1:=sId
        Set rngCopy = rngData.SpecialCells(xlVisible)
        .AutoFilterMode = False
    End With
   
    ' new sheet
    With wsNew
        rngCopy.Copy .Range("A1")
        .Activate
        .Range("A1").Select
    End With
    
    MsgBox "Data for " & sId & " " & sName _
         & " copied to " & wsNew.Name, vbInformation
   
End Sub

方案2：生成带递增编号的替代名称 #

如果不想删除原有工作表，而是创建新的带编号的工作表（比如张三存在时，创建张三(1)、张三(2)等），可以添加一个辅助函数来生成可用的工作表名称，再进行后续操作。

步骤1：添加辅助函数 #

在模块中添加以下函数，用于生成不重复的工作表名称：

Function GetUniqueSheetName(baseName As String) As String
    Dim i As Integer
    Dim tempName As String
    i = 1
    tempName = baseName
    ' 循环检测名称是否存在
    Do While SheetExists(tempName)
        tempName = baseName & "(" & i & ")"
        i = i + 1
    Loop
    GetUniqueSheetName = tempName
End Function

Function SheetExists(sheetName As String) As Boolean
    Dim ws As Worksheet
    On Error Resume Next
    Set ws = ThisWorkbook.Sheets(sheetName)
    On Error GoTo 0
    SheetExists = Not ws Is Nothing
End Function

步骤2：修改原代码的工作表创建逻辑 #

替换原代码中检测工作表存在的部分：

' 获取不重复的工作表名称
Dim finalSheetName As String
finalSheetName = GetUniqueSheetName(sName)

' 创建新工作表
Set wsNew = Sheets.Add(after:=Sheets(Sheets.Count))
wsNew.Name = finalSheetName

' 根据是否是原名称给出不同提示
If finalSheetName = sName Then
    MsgBox "The sheet has been successfully created. Wait a few seconds until Excel pastes the data from : " & finalSheetName, vbInformation
Else
    MsgBox "Sheet '" & sName & "' already exists, created sheet '" & finalSheetName & "' instead", vbExclamation, "Notice"
End If

完整修改后的代码：

Option Explicit

Sub createsheet()

    Const COL_HA = 6 ' F on data sheet is Health Auth

    Dim sName As String, sId As String
    Dim wsNew As Worksheet, wsUser As Worksheet
    Dim wsIndex As Worksheet, wsData As Worksheet
    Dim rngName As Range, rngCopy As Range
    
    With ThisWorkbook
         Set wsUser = .Sheets("user")
         Set wsData = .Sheets("data")
         Set wsIndex = .Sheets("index")
    End With
         
    ' find row in index table for name from drop down
    sName = Left(wsUser.Range("M42").Value, 30)
    Set rngName = wsIndex.Range("L5:L32").Find(sName)
    If rngName Is Nothing Then
        MsgBox "Could not find " & sName & " on index sheet", vbCritical
        Exit Sub ' 找不到名称时直接退出，避免后续报错
    Else
        sId = rngName.Offset(, -1) ' column to left
    End If
    
    ' 获取不重复的工作表名称
    Dim finalSheetName As String
    finalSheetName = GetUniqueSheetName(sName)

    ' 创建新工作表
    Set wsNew = Sheets.Add(after:=Sheets(Sheets.Count))
    wsNew.Name = finalSheetName

    ' 根据是否是原名称给出不同提示
    If finalSheetName = sName Then
        MsgBox "The sheet has been successfully created. Wait a few seconds until Excel pastes the data from : " & finalSheetName, vbInformation
    Else
        MsgBox "Sheet '" & sName & "' already exists, created sheet '" & finalSheetName & "' instead", vbExclamation, "Notice"
    End If
    
    ' filter sheet and copy data
    Dim lastrow As Long, rngData As Range
    With wsData
        lastrow = .Cells(.Rows.Count, COL_HA).End(xlUp).Row
        Set rngData = .Range("A10:Z" & lastrow)
        .AutoFilterMode = False
        rngData.AutoFilter Field:=COL_HA, Criteria1:=sId
        Set rngCopy = rngData.SpecialCells(xlVisible)
        .AutoFilterMode = False
    End With
   
    ' new sheet
    With wsNew
        rngCopy.Copy .Range("A1")
        .Activate
        .Range("A1").Select
    End With
    
    MsgBox "Data for " & sId & " " & sName _
         & " copied to " & wsNew.Name, vbInformation
   
End Sub

Function GetUniqueSheetName(baseName As String) As String
    Dim i As Integer
    Dim tempName As String
    i = 1
    tempName = baseName
    ' 循环检测名称是否存在
    Do While SheetExists(tempName)
        tempName = baseName & "(" & i & ")"
        i = i + 1
    Loop
    GetUniqueSheetName = tempName
End Function

Function SheetExists(sheetName As String) As Boolean
    Dim ws As Worksheet
    On Error Resume Next
    Set ws = ThisWorkbook.Sheets(sheetName)
    On Error GoTo 0
    SheetExists = Not ws Is Nothing
End Function

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