Sub craetenames()
Dim i As Long, LR As Long, NR As Long, nome As String, sh As Worksheet, ws As Worksheet

    Application.ScreenUpdating = False
    On Error Resume Next
    
    For Each ws In ThisWorkbook.Worksheets
        With ws
            If .Name <> "Source Data" Then
            .Cells.ClearContents
            End If
        End With
    Next ws
    
        With Sheets("Source Data")
            LR = .Cells.Find("*", , , , xlByRows, xlPrevious).Row
            For i = 2 To LR
                If Trim(.Range("A" & i).Value) <> vbNullString Then
                    nome = Trim(.Range("A" & i).Value)
                    If Not Evaluate("ISREF('" & nome & "'!A1)") Then
                    Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = nome
                    End If
                    .Range("A1:F1").Copy Worksheets(nome).Range("A1")
                    .Rows(i).Copy
                    Worksheets(nome).Range("A" & Rows.Count).End(xlUp)(2).PasteSpecial (xlPasteValuesAndNumberFormats)
                End If
            Next i
        Application.CutCopyMode = 0
       End With
       
            For Each sh In ThisWorkbook.Worksheets
                Application.DisplayAlerts = 0
                If InStr((sh.Name), "Sheet") > 0 Then sh.Delete
                 sh.Cells.Columns.AutoFit
            Next
        
     Application.ScreenUpdating = True
     Application.DisplayAlerts = 1
End Sub