جزاك الله خير يا غالى

Sub NewTest()
    Dim ws          As Worksheet
    Dim objComp     As Object
    Dim xPath       As String
    
    xPath = Application.ActiveWorkbook.Path
    
    '------------------------------
    'New Lines
    Dim aWorksheets, e
    aWorksheets = Array("Data", "Main") '>> Put Sheet Names Here
    '------------------------------
    
    '''Set ws = Sheets("Data")
    
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.DisplayAlerts = False
    
        '-----------------------------
        'New Loop
        For Each e In aWorksheets
        
            'Assign The Worksheet
            Set ws = ThisWorkbook.Worksheets(e)
            '---------------------------
            
            With ws
                .Copy
                Application.ActiveWorkbook.SaveAs Filename:=xPath & "" & .Name & ".xlsm", FileFormat:=xlOpenXMLWorkbookMacroEnabled
                ActiveSheet.UsedRange.Value = ActiveSheet.UsedRange.Value
    
                With ActiveWorkbook.VBProject.VBComponents(ws.CodeName).CodeModule
                    .DeleteLines 1, .CountOfLines
                    .InsertLines 1, "Option Explicit"
                End With
                
                For Each objComp In ActiveSheet.Parent.VBProject.VBComponents
                    If (objComp.Name = ActiveSheet.CodeName) Then objComp.Name = "Sheet1"
                Next objComp
                
                On Error Resume Next
                    ActiveSheet.Shapes("Button 1").Delete
                On Error GoTo 0
                
                Application.ActiveWorkbook.Close True
            End With
            
        '---------------------------
        'Related To New Loop
        Next e
        '---------------------------
        
    Application.DisplayAlerts = True
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    
    MsgBox "Done...", 64
End Sub