أكاديمية الصقر للتدريب

لوحة التميز الأسبوعي
العضو المتميز المشرف المتميز المراقب المتميز المدير المتميز الموضوع المتميز القسم المتميز
العضو المتميز المشرف المتميز المراقب المتميز المدير المتميز الموضوع المتميز القسم المتميز
هانى على لا تميز خلال هذه الفترة-- لا تميز خلال هذه الفترة YasserKhalil الترقيم بشرط معين اكسيل اسئله واجابات


أهلا وسهلا بك زائرنا الكريم في أكاديمية الصقر للتدريب، لكي تتمكن من المشاركة ومشاهدة جميع أقسام المنتدى وكافة الميزات ، يجب عليك إنشاء حساب جديد بالتسجيل بالضغط هنا أو تسجيل الدخول اضغط هنا إذا كنت عضواً .





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

السلام عليكم ورحمة الله وبركاته هذا الكود لأستاذنا العلامة الفهامة الأستاذ/ ياسر حفظه الله ورعاه وبارك الله له على ما يق ..


موضوع مغلق


03-10-2021 06:36 مساء
علي بطيخ سالم
عضو محترف
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 19-09-2018
رقم العضوية : 8086
المشاركات : 272
الجنس : ذكر
تاريخ الميلاد : 30-10-1982
الدعوات : 1
يتابعهم : 7
يتابعونه : 3
قوة السمعة : 1084
عدد الإجابات: 12
 offline 

السلام عليكم ورحمة الله وبركاته

هذا الكود لأستاذنا العلامة الفهامة الأستاذ/ ياسر حفظه الله ورعاه وبارك الله له على ما يقدمه من أعمال جليلة

الكود يعمل بشكل جيد لكن احتاج التعديل عليه بحيث يتم تصدير ورقة العمل بنفس مسمى الورقة بدون الرجوع إلى الكود في التسمية على اعتبار أن لدى ملف يحتوي على 80 ورقة عمل وهو المقصود من هذا السطر

 Set ws = Sheets("Data")

وذلك لنسخ زر الكود إلى جميع أوراق العمل وتصدير كل ورقة باسمها

بارك الله فيكم وشكرا على مجهودكم الطيب
طبعاً أنا عارف قوانين المنتدى كويس وهذا التنبيه دائماً ما يذكره لنا الاستاذ ياسر بعدم تخصيص شخص بعينه داخل المنتدى ليكون الموضوع متاح للجميع لكن أنا بحثت على المواضيع في هذا الشأن ووجدت ذلك الكود فرفعت الملف بأكمله دون اجتهاد مني


 
 
  Export Specific Sheet To New Workbook YasserKhalil Excel-Egy.xlsm   تحميل xlsm مرات التحميل :(8)
الحجم :(25.741) KB



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


وضعت لك في الكود تعليقات بالأسطر التي تمت إضافتها لعمل حلقة تكرارية
عرض الإجابة




03-10-2021 07:17 مساء
مشاهدة مشاركة منفردة [1]
YasserKhalil
مراقب عام
معلومات الكاتب ▼
تاريخ الإنضمام : 21-08-2017
رقم العضوية : 3
المشاركات : 10445
الجنس : ذكر
تاريخ الميلاد : 1-10-1978
الدعوات : 24
يتابعهم : 1
يتابعونه : 535
قوة السمعة : 36552
عدد الإجابات: 254
 offline 
look/images/icons/i1.gif تصدير ورقة عمل بنفس مسماها من شيت يحتوي على 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


وضعت لك في الكود تعليقات بالأسطر التي تمت إضافتها لعمل حلقة تكرارية

04-10-2021 07:59 صباحا
مشاهدة مشاركة منفردة [2]
علي بطيخ سالم
عضو محترف
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 19-09-2018
رقم العضوية : 8086
المشاركات : 272
الجنس : ذكر
تاريخ الميلاد : 30-10-1982
الدعوات : 1
يتابعهم : 7
يتابعونه : 3
قوة السمعة : 1084
عدد الإجابات: 12
 offline 
look/images/icons/i1.gif تصدير ورقة عمل بنفس مسماها من شيت يحتوي على 80 ورقة عمل
استاذنا بارك الله لك وجزاك الله خيرا ورحم الله والديك... لكن لاحظت شيء في بعض الأوراق التي يتم تصدير ها وهي كبر حجم الشيت عن المعتاد فقد يبلغ حجمه ٥ ميجا بالرغم من عدم احتوائه على بيانات غير بعض الكلمات وجدول صغير

04-10-2021 10:03 صباحا
مشاهدة مشاركة منفردة [3]
YasserKhalil
مراقب عام
معلومات الكاتب ▼
تاريخ الإنضمام : 21-08-2017
رقم العضوية : 3
المشاركات : 10445
الجنس : ذكر
تاريخ الميلاد : 1-10-1978
الدعوات : 24
يتابعهم : 1
يتابعونه : 535
قوة السمعة : 36552
عدد الإجابات: 254
 offline 
look/images/icons/i1.gif تصدير ورقة عمل بنفس مسماها من شيت يحتوي على 80 ورقة عمل
قد يكون هناك تنسيقات أو ما شابه في الورقة التي تم تصديرها أو يوجد الكثير من النطاقات المسماة ، لا يمكن الحكم بشكل نهائي إلا بعد الإطلاع على إحدى هذه الأوراق. إذا كنت تريد المزيد من المساعدة قم بإرفاق ملف يحتوي على ورقة عمل ينطبق عليها ما قلته وتأكد أن حجم الورقة بعد عملية التصدير يزيد حجمه.

04-10-2021 03:44 مساء
مشاهدة مشاركة منفردة [4]
علي بطيخ سالم
عضو محترف
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 19-09-2018
رقم العضوية : 8086
المشاركات : 272
الجنس : ذكر
تاريخ الميلاد : 30-10-1982
الدعوات : 1
يتابعهم : 7
يتابعونه : 3
قوة السمعة : 1084
عدد الإجابات: 12
 offline 
look/images/icons/i1.gif تصدير ورقة عمل بنفس مسماها من شيت يحتوي على 80 ورقة عمل
تمام جزاك الله خيرا وبارك الله لك استاذنا ونفع الله بعلمك وجعله في ميزان حسناتك اللهم آمين يارب العالمين 

04-10-2021 08:17 مساء
مشاهدة مشاركة منفردة [5]
YasserKhalil
مراقب عام
معلومات الكاتب ▼
تاريخ الإنضمام : 21-08-2017
رقم العضوية : 3
المشاركات : 10445
الجنس : ذكر
تاريخ الميلاد : 1-10-1978
الدعوات : 24
يتابعهم : 1
يتابعونه : 535
قوة السمعة : 36552
عدد الإجابات: 254
 offline 
look/images/icons/i1.gif تصدير ورقة عمل بنفس مسماها من شيت يحتوي على 80 ورقة عمل
وجزيت خيراً أخي العزيز علي ومشكور على دعائك الطيب



الكلمات الدلالية
يحتوي ، مسماها ، بنفس ، ورقة ، تصدير ، ورقة ،


 










اخلاء مسئولية: يخلى منتدى أكاديمية الصقر للتدريب مسئوليته عن اى مواضيع او مشاركات تندرج داخل الموقع ويحثكم على التواصل معنا ان كانت هناك اى إنتهاكات تتضمن اى انتهاك لحقوق الملكية الفكرية او الادبية لاى جهة - بالتواصل معنا من خلال نموذج مراسلة الإدارة .وسيتم اتخاذ الاجراءات اللازمة.
سياسة النشر: التعليقات المنشورة لا تعبر عن رأي منتدى أكاديمية الصقر للتدريب ولا نتحمل أي مسؤولية قانونية حيال ذلك ويتحمل كاتبها مسؤولية النشر.

الساعة الآن 07:34 صباحا