Navngive faneblad og opret nye automatisk

stil dig på arket og kør makroen MakeSheets

Sub MakeSheets()
Dim rg As Range
Dim sh As Worksheet
Set rg = Range("A1:A300")
On Error Resume Next
For Each c In rg
    If Len(c) > 0 Then
        If Not SheetExist(c.Text) Then
            Set sh = Worksheets.Add
            sh.Name = c.Value
        End If
    End If
Next
End Sub

Function SheetExist(shname) As Boolean
Dim x As Object
On Error Resume Next
Set x = ActiveWorkbook.Sheets(shname)
If Err = 0 Then SheetExist = True Else SheetExist = False
End Function

Jeg har fået det til at køre men hvis det ikke er for meget forlangt
vil det være rart hvis tallene kommer efter de 3ark der er permanente.
De tal man skriver i A1:A300 skal bliver ved med at være der. hvis
man sletter eller opretter ny i A1:a300 skal den selv kunne slette eller tilføge
nye faner.Hver gang man køre markroen. Det lyder svært men jeg har se at du er en af de skrappe. På forhånd Mange Tak

Tilføgelse fejl tallende bliver på ark1 jeg havde ikke  se at jeg stod i andet ark
så kan det ikke lade sig gøre at ende i ark1 efter markro kørslen på forhånd tak

jo.

Sub MakeSheets()
Dim rg As Range
Dim sh As Worksheet
Dim temp, bfound As Boolean
Application.ScreenUpdating = False
Set rg = Sheets("Ark1").Range("A1:A300")
'indsæt
For Each c In rg
    If Len(c) > 0 Then
        If Not SheetExist(c.Text) Then
            Set sh = Worksheets.Add(after:=Sheets(Worksheets.Count))
            sh.Name = c.Value
        End If
    End If
Next
'slet
temp = rg
'spring de første 3 ark over
For x = 4 To ActiveWorkbook.Worksheets.Count
    bfound = False
    For y = 1 To UBound(temp, 1)
        If temp(y, 1) <> "" Then
            If Worksheets(x).Name = CStr(temp(y, 1)) Then
                bfound = True
                Exit For
            End If
        End If
    Next
   
    If bfound = False Then
        Application.DisplayAlerts = False
        Worksheets(x).Delete
        Application.DisplayAlerts = True
    End If
Next
Sheets("Ark1").Select
Application.ScreenUpdating = True
End Sub

Function SheetExist(shname) As Boolean
Dim x As Object
    On Error Resume Next
    Set x = ActiveWorkbook.Sheets(shname)
    If Err = 0 Then SheetExist = True Else SheetExist = False
End Function

tak for hjælpen det virker send et svar så du kan få dine point