وعليكم السلام أخي العزيز علي
بارك الله فيك على كلماتك الطيبة وما العبد لله إلا متعلم لا أكثر ولا أقل
في الكود استبدل السطر التالي
بهذا السطر
وإذا كان الكود سيطبق على أكثر من ورقة عمل فلا داعي لعمل زر لكل ورقة عمل بل يمكن عمل حلقة تكرارية بحيث يتم تصدير كل أوراق العمل بضغطة زر واحدة
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
وضعت لك في الكود تعليقات بالأسطر التي تمت إضافتها لعمل حلقة تكرارية