Microsoft Excel VBA Intersect with Rename Sheet

Question

I'm trying to change the name of a sheet after it is created under and Intersect method. The code I have below give Error 424. The code works when only creating a new sheet.

Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
Set Active_Range = Range("B6:F11")
    If Not Application.Intersect(Target, Active_Range) Is Nothing Then
        Sheets("Employee Details").Copy after:=Sheets("Job Schedule")
        Sheets("Employee Details (2)").Name.Value = "Name One"
    End If
End Sub

I have tried creating a trigger for the workbook that renames the new sheet when it is created but that does not work either.

Private Sub Workbook_NewSheet(ByVal Sh As Object)
    Sh.Name.Value = "Name One"
End Sub

Answer 1

Is this what you are trying? (Not fully tested)

Option Explicit

Private Sub Workbook_NewSheet(ByVal Sh As Object)
    '~~> This is the name that you want to give
    Dim Nm As String
    Nm = "Name One"
    
    '~~> Check if this name is already taken
    Dim ws As Worksheet
    On Error Resume Next
    Set ws = ThisWorkbook.Sheets(Nm)
    On Error GoTo 0
    
    If Not ws Is Nothing Then
        '~~> Name the new worksheet
        ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count).Name = Nm
    Else
        '~~> Alert user and delete the newly created sheet
        MsgBox "This name is already taken"
        Application.DisplayAlerts = False
        ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count).Delete
        Application.DisplayAlerts = True
    End If
End Sub

Answer 2

sticking to your "Workbook_NewSheet" approach

1. in any Module code pane, put this at the very top

    Option Private Module ' make the Public variables "local" to current VBA project only
    Public newSheetName As String ' this variable will be available to any other Sub, Function of this Project
   

2. in ThisWorkbook code pane, put this

    Private Sub Workbook_NewSheet(ByVal Sh As Object)
        Sh.Name = newSheetName
    End Sub
   

3. in your relevant Worksheet code pane, put this

    Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
        Dim Active_Range  As Range
        Set Active_Range = Range("B6:F11")
            If Not Application.Intersect(Target, Active_Range) Is Nothing Then
                newSheetName = "Name One" ' set the public variable
                Sheets("Employee Details").Copy after:=Sheets("Job Schedule")
            End If
    End Sub
   

After that, you may want to add code (I'd do that in "Workbook_NewSheet()" to ensure the new worksheet name: a) matches the sheet name rules b) isn't already used for another sheet in the same workbook

Answer 3

 Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
     Dim Active_Range  As Range
     Set Active_Range = Range("B6:F11")
         If Not Application.Intersect(Target, Active_Range) Is Nothing Then
             Name2 = ActiveCell().Value
             Sheets("Employee Details").Copy After:=Sheets("Job Schedule")
             Worksheets("Employee Details (2)").Name = "Employee Details - " + Name2
             
         End If
 End Sub

Above is what I came up with after digging and reading a little more.

Answer 4

A Worksheet BeforeRightClick: Copy and Rename Template Worksheet

Sheet Module e.g. Sheet1

Option Explicit

Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
    AddNewEmployeeDetails Target, Cancel
End Sub

Standard Module e.g. Module1

Option Explicit

Sub AddNewEmployeeDetails(ByVal Target As Range, ByRef Cancel As Boolean)
    
    Const PROC_TITLE As String = "Add New Employee Details Sheet"
    
    Const TARGET_RANGE As String = "B6:F11"
    Const SRC_SHEET_NAME As String = "Employee Details"
    Const AFTER_SHEET_NAME As String = "Job Schedule"
    Const DST_SHEET_NAME_PREFIX As String = "Employee Details - "
    
    Dim tws As Worksheet: Set tws = Target.Worksheet
    
    Dim trg As Range: Set trg = Intersect(tws.Range(TARGET_RANGE), Target)
    If trg Is Nothing Then Exit Sub
    
    Dim eName As String: eName = CStr(Target.Value) ' for the message boxes
    Dim dName As String: dName = DST_SHEET_NAME_PREFIX & eName
    
    Dim wb As Workbook: Set wb = tws.Parent
    
    Dim dsh As Object
    On Error Resume Next ' to prevent error if sheet doesn't exist
        Set dsh = wb.Sheets(dName)
    On Error GoTo 0
    
    If dsh Is Nothing Then ' sheet doesn't exist
        
        Dim sws As Worksheet: Set sws = wb.Sheets(SRC_SHEET_NAME)
        Dim aws As Worksheet: Set aws = wb.Sheets(AFTER_SHEET_NAME)
        
        sws.Copy After:=aws
        
        Dim dws As Worksheet: Set dws = aws.Next
        
        Dim ErrNumber As Long, ErrDescription As String
        
        On Error Resume Next ' to prevent error if invalid sheet name
            dws.Name = dName
            ErrNumber = Err.Number
            ErrDescription = Err.Description
        On Error GoTo 0
        
        If ErrNumber <> 0 Then ' sheet name is invalid
            Application.DisplayAlerts = False ' to delete without confirmation
                dws.Delete
            Application.DisplayAlerts = True
            tws.Select
            MsgBox "Run-time error '" & ErrNumber & "':" & vbLf & vbLf _
                & ErrDescription & vbLf & vbLf & "Could not rename to """ _
                & dName & """.", vbCritical, PROC_TITLE
        Else ' sheet name is valid
            MsgBox "Employee Details sheet for " & eName & " added.", _
                vbInformation, PROC_TITLE
        End If
    
    Else ' sheet exists
        
        MsgBox "The Employee Details sheet for " & eName _
            & " already exists.", vbCritical, PROC_TITLE
    
    End If
    
    Cancel = True

End Sub