Excel VBA Code to Create New Sheets Upon New Entry In Field

Okay, so I need a macro that will add new sheets to a workbook when new names are added to the specified field.

The code below is one which I found online and it works for the purposes of creating sheets per entry in the field (column A), however, whenever I add more names to the list in column A, and try to run the code again, I get an error message (see below)

:confused:
Attachment 111455

Code:

---

Public Sub Extraction_to_new_sheets()
     
    Dim My_Range As Range
    Dim My_Cell As Variant
    Dim sh_Original As Worksheet
   
    Application.DisplayAlerts = False
    Application.Calculation = xlCalculationManual
    Application.ScreenUpdating = False
         
    Set sh_Original = ActiveSheet
   
    On Error Resume Next
    Sheets("TEMPXXX").Delete
    On Error GoTo 0
    Worksheets.Add
    ActiveSheet.Name = "TEMPXXX"
         
    Worksheets("Sheet1").Columns("A:A").AdvancedFilter Action:=xlFilterCopy, _
    CopyToRange:=Columns("A:A"), Unique:=True
   
    Set My_Range = Range("A2:A" & Range("A65536").End(xlUp).Row)
         
    For Each My_Cell In My_Range
       
        On Error Resume Next
        Sheets(My_Cell.Value).Delete 'delete if already exists
        On Error GoTo 0
        Worksheets.Add
        ActiveSheet.Name = My_Cell.Value
               
        sh_Original.UsedRange.AutoFilter Field:=1, Criteria1:=My_Cell.Value
        sh_Original.Cells.SpecialCells(xlVisible).Copy Destination:=Range("A1")
        Columns.AutoFit
    Next
   
    Worksheets("TEMPXXX").Delete
    sh_Original.AutoFilterMode = False
    Set sh_Original = Nothing
   
    Application.DisplayAlerts = True
    Application.Calculation = xlAutomatic
    Application.ScreenUpdating = True
   
End Sub

---

the error probably indicates that you are again trying to add a sheet then giving the name of an existing sheet

you are first removing all sheets, but have no idea if they are all removed, as that code is masked by on error resume next
first REMOVE OERN, then if errors may occur, use proper methods to handle or eliminate errors
stop relying on the correct sheet being the active sheet
try like

Code:

---

set newsht = worksheets.add
newsht.name = my_cell.value
        sh_Original.UsedRange.AutoFilter Field:=1, Criteria1:=My_Cell.Value
        sh_Original.Cells.SpecialCells(xlVisible).Copy Destination:=newsht.Range("A1")
        newsht.Columns.AutoFit

---

Maybe this, would stop you having to re-run the code.

THis code will not delete/re-create the sheet if it already exists. Unless you want it to do that?

Code:

---

Private Sub Worksheet_Change(ByVal Target As Range)
Dim ws As Worksheet
    If Target.Column = 1 Then
        For Each ws In ActiveWorkbook.Worksheets
            If LCase(ws.Name) = LCase(Target.Cells.Value) Then Exit Sub
        Next ws
            Worksheets.Add(after:=Worksheets(Worksheets.Count)).Name = Target.Cells.Value
    End If
End Sub

---