Creating a New Worksheet within the same Workbook based on the data within a cell from a table

[Vonsteiner]

Hello,

I am having difficulty getting the syntax right for this VBA code I am working on. Basically I have a table where the sales person will add new rows as they begin a new action. I am trying to have Excel create a new worksheet based off a template and name the new worksheet with the cell value. The table name is MasterActionList. The table column is column 4 or "Action Name". I have a worksheet within the workbook named "Template". I have tried the code with the range set to the table column and as it is with just using the column range.

Private Sub CreateAndNameWorksheets()

    Dim c As Range
    Dim ac As Range
    
    Application.ScreenUpdating = False
    
    'ac = ActiveSheet.ListObjects("MasterActionList").ListColumns(4).Range.Select
    
    Sheets("All Actions").Select
    
    For Each c In Range("D2:D201")
        c.Select
        Sheets.Add After:=Sheets(Sheets.Count)
        Sheets(Sheets.Count).Name = c.Value
        Sheets("Template").Cells.Copy
        ActiveSheet.Paste
        Range("A1").Select
        Application.CutCopyMode = False
        Sheets("All Actions").Select
        ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:="", SubAddress:=c.Value & "!A1", TextToDisplay:=c.Value
        
    Next c
    
    Application.ScreenUpdating = True
    
End Sub

Any help would be most appreciated. Thank you.

 

[FatBoyClam]

You could have added the formula to the Template sheet in cell A1, that would also work...

 

[FatBoyClam]

This code will check for the value of the cell being blank, containing one of the forbidden characters, being more than 31 characters long or matching the name of a sheet that already exists.

Sub Worksheet_Change(ByVal Target As Range)

    Dim c As Range
    Dim ac As Range
    Dim tbl As ListObject
    Dim lCol As ListColumn
    Dim i As Integer
    
   
   
    Application.ScreenUpdating = False
   
    Set tbl = ActiveSheet.ListObjects("MasterActionList")
   
    Set lCol = tbl.ListColumns(4)
   
    Set c = lCol.DataBodyRange.Cells(lCol.DataBodyRange.Rows.Count, 1)
   
    If Not Application.Intersect(Target, c) Is Nothing And Target.CountLarge = 1 Then
   
        If Target.Value = "" Then
            MsgBox "Cannot create a sheet with blank name" & vbCrLf & "Please enter an alternative value"
            Exit Sub
        End If
        
        If InStr(Target.Value, "\") > 0 Then
            MsgBox "You cannot use any of the following characters, please try another value. " & vbCrLf & vbCrLf & "\ / * [ ] : ?"
            Target.Activate
            Exit Sub
        ElseIf InStr(Target.Value, "/") > 0 Then
            MsgBox "You cannot use any of the following characters, please try another value. " & vbCrLf & vbCrLf & "\ / * [ ] : ?"
            Target.Activate
            Exit Sub
        ElseIf InStr(Target.Value, "*") > 0 Then
            MsgBox "You cannot use any of the following characters, please try another value. " & vbCrLf & vbCrLf & "\ / * [ ] : ?"
            Target.Activate
            Exit Sub
        ElseIf InStr(Target.Value, "[") > 0 Then
            MsgBox "You cannot use any of the following characters, please try another value. " & vbCrLf & vbCrLf & "\ / * [ ] : ?"
            Target.Activate
            Exit Sub
        ElseIf InStr(Target.Value, "]") > 0 Then
            MsgBox "You cannot use any of the following characters, please try another value. " & vbCrLf & vbCrLf & "\ / * [ ] : ?"
            Target.Activate
            Exit Sub
        ElseIf InStr(Target.Value, ":") > 0 Then
            MsgBox "You cannot use any of the following characters, please try another value. " & vbCrLf & vbCrLf & "\ / * [ ] : ?"
            Target.Activate
            Exit Sub
        ElseIf InStr(Target.Value, "?") > 0 Then
            MsgBox "You cannot use any of the following characters, please try another value. " & vbCrLf & vbCrLf & "\ / * [ ] : ?"
            Target.Activate
            Exit Sub
        End If
        
        If Len(Target.Value) > 31 Then
            MsgBox "You may not enter a value more than 31 characters long (" & Len(Target.Value) & " used)"
            Target.Activate
            Exit Sub
        End If
        
        For i = 1 To Sheets.Count
            If ThisWorkbook.Sheets(i).Name = Target.Value Then
            
                MsgBox "There is already a worksheet called " & Target.Value & vbCrLf & "Please enter a different value"
                Target.Activate
                Exit Sub
            
            End If
        Next i
   
        Sheets.Add After:=Sheets(Sheets.Count)
        Sheets(Sheets.Count).Name = c.Value
        Sheets("Template").Cells.Copy
        ActiveSheet.Paste
        ActiveSheet.Range("A1").Select
        ActiveSheet.Range("A1").Value = c.Value
        Application.CutCopyMode = False
        Target.Worksheet.Activate
        ActiveSheet.Hyperlinks.Add Anchor:=Target, Address:="", SubAddress:="'" & c.Value & "'!A1", TextToDisplay:=c.Value
       
    End If
   
    Application.ScreenUpdating = True


End Sub

 

[Vonsteiner]

Awesome! I am not sure why I didn't think to put the formula into the template worksheet. I put all the formatting in there. This works perfectly. Thank you very much!

 

[FatBoyClam]

Glad to help, thanks for the feedback