تصدير ورقة عمل بنفس مسماها من شيت يحتوي على 80 ورقة عمل

Set ws = Sheets("Data")

Set ws = ActiveSheet

Sub Export_Specific_Sheet_To_New_Workbook_Delete_VBA_Codes()

    Dim ws          As Worksheet

    Dim objComp     As Object

    Dim xPath       As String

    

    xPath = Application.ActiveWorkbook.Path

    

    'I have commented this line

    'Set ws = Sheets("Data")

    

    Application.ScreenUpdating = False

    Application.EnableEvents = False

    Application.DisplayAlerts = False

    For Each ws In ThisWorkbook.Worksheets  'New line for looping

    If ws.Name = "Main" Or ws.Name = "Sheet1" Then GoTo Skipper 'Exclude specific sheets

        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

Skipper:    'To exclude the specific sheets

    Next ws 'New line for looping

    

    Application.DisplayAlerts = True

    Application.EnableEvents = True

    Application.ScreenUpdating = True

    

    MsgBox "Done...", 64

End Sub