If duplicate sheet create it with an alternative name-CodePudding

I have the following code that creates a new sheet filtering some data:

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
    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
        ' exists
        MsgBox "Sheet '" & sName & "' already exists", vbCritical, "Error"
        Exit Sub
    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

I need the macro to be able to run multiple times.

In the case the sheet existed because you runned the macro more than one, apart from the error message being displayed I need that the new sheet is still created, either with an alternate name or by deleting the original sheet. I can't figure out how to do that.

CodePudding user response：

Just change part of your code to this:

' create sheet but check if already exists
On Error Resume Next
Set shNew = Sheets(sName)
counter = 1
Dim sNewName As String
If Not shNew Is Nothing Then
  MsgBox sName & " sheet already exists."
  While Not shNew Is Nothing
    sNewName = sName & counter
    counter = counter   1
    Set shNew = Nothing
    Set shNew = Sheets(sNewName)
  Wend
  sName = sNewName
End If
Set wsNew = Sheets(sName)
On Error GoTo 0

and don't forget to declare variables

CodePudding user response：

Delete and Add Worksheet With the Same Name

On Error Resume Next
Set wsNew = ThisWorkbook.Sheets(sName)
On Error GoTo 0

If Not wsNew Is Nothing Then ' it exists
    Application.DisplayAlerts = False ' to delete without confirmation
    wsNew.Delete
    Application.DisplayAlerts = True
End If

With ThisWorkbook
    Set wsNew = .Sheets.Add(After:=.Sheets(.Sheets.Count))
End With

wsNew.Name = sName