Copying a sheet with the same name and add an increasing number to the name-CodePudding

I'm creating a sheet save function and ideally i would like it to take the intails from names in two cells then add it to the sheet name but if it comes across a copy add a number to the end. I have looked around the internet for some answers which has somewhat helped me to develop my own

Here is what I have got so far,

So the Button

Sub Test()

  'Copy New Sheet
  
    Sheets("Blank MAR").Copy Before:=Sheets(1)

    Sheets("Blank MAR (2)").Name = Funct.GetUniqueName
End Sub

then the functions

Function Get_in()

Get_in = Left(Range("B1"), 1) & Left(Range("C1"), 1)   " "   Range("B2")

End Function


Function GetUniqueName(strProject As String) As String

    ' If this is the first time it's being used, just return it without a number...
    If Not SheetNameExists(Funct.Get_in) Then
        GetUniqueName = Funct.Get_in
    
        Exit Function
    End If

    ' Otherwise, suffix the sheet name with a number, starting at 2...
    Dim i As Long, strName As String
    i = 1

    Do
        i = i   1
        strName = "Funct.Get_in(" & i & ")"
    Loop While SheetNameExists(strName)

    GetUniqueName = strName

End Function

Function SheetNameExists(strName As String) As Boolean
    Dim sh As Worksheet
    For Each sh In Worksheets
        If StrComp(sh.Name, strName, vbTextCompare) = 0 Then
            SheetNameExists = True
            Exit Function
        End If
    Next
End Function

Hope someone can help Many thanks

CodePudding user response：

Add Increment If Sheet Exists

Sub Test()
    
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    Dim sws As Worksheet: Set sws = wb.Worksheets("Blank MAR")
    Dim BaseName As String: BaseName = GetBaseName(sws)
    
    sws.Copy Before:=wb.Sheets(1)
    
    Dim dws As Worksheet: Set dws = wb.Sheets(1)
    Dim UniqueName As String: UniqueName = GetUniqueSheetName(wb, BaseName)
    
    dws.Name = UniqueName
    
End Sub

The Help

Function GetBaseName( _
    ByVal ws As Worksheet) _
As String
    GetBaseName = Left(ws.Range("B1"), 1) _
        & Left(ws.Range("C1"), 1) & " " & ws.Range("B2")
End Function

Function GetUniqueSheetName( _
    ByVal wb As Workbook, _
    ByVal BaseName As String) _
As String
    Dim UniqueName As String: UniqueName = BaseName
    Dim n As Long: n = 1
    
    Do While IsSheetNameTaken(wb, UniqueName)
        n = n   1
        UniqueName = BaseName & " (" & n & ")"
    Loop
    
    GetUniqueSheetName = UniqueName
End Function

Function IsSheetNameTaken( _
    ByVal wb As Workbook, _
    ByVal SheetName As String) _
As Boolean
    Dim sh As Object
    On Error Resume Next
        Set sh = wb.Sheets(SheetName)
    On Error GoTo 0
    IsSheetNameTaken = Not sh Is Nothing
End Function

The Short Versions

Sub TestShorter()
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    Dim sws As Worksheet: Set sws = wb.Worksheets("Blank MAR")
    sws.Copy Before:=wb.Sheets(1)
    wb.Sheets(1).Name = GetUniqueSheetName(wb, GetBaseName(sws))
End Sub

Sub TestShortest()
    Dim sws As Worksheet: Set sws = ThisWorkbook.Worksheets("Blank MAR")
    sws.Copy Before:=sws.Parent.Sheets(1)
    sws.Parent.Sheets(1).Name = GetUniqueSheetName(sws.Parent, GetBaseName(sws))
End Sub