إجمالي مرات مشاهدة الصفحة

السبت، 23 أبريل 2016

تصدير أوراق العمل المحددة أو النشطة إلى مصنف جديد Export Selected Sheets To New Workbook

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

أقدم لكم كود يقوم بتصدير أوراق العمل التي تقوم بتحديدها أو تنشيطها إلى منصف جديد ، ويتم تحويل المعادلات إلى قيم.

بفرض أن لديك مجموعة أوراق عمل وتحتوي بعض أوراق العمل على معادلات ، وأردت على سبيل المثال تصدير ورقتي عمل من المصنف الحالي (ورقة العمل Main وورقة العمل Search) ، يمكنك تحديد ورقة العمل Main ثم الضغط على مفتاح Ctrl من لوحة المفاتيح ثم تحديد ورقة العمل Search ، ثم اضغط Alt + F8 من لوحة المفاتيح واختر الإجراء الفرعي المسمى Export_Selected_Sheets ثم انقر الأمر Run ليتم تصدير ورقتي العمل اللتين قمت بتحديدهما إلى مصنف جديد باسم Exported في نفس مسار المصنف الحالي.

وأخيراً إليكم الكود ويوضع في موديول عادي :

Sub Export_Selected_Sheets()
    Dim Ws As Worksheet
    Dim ArrSheetToCopy() As String
    Dim N As Long
    Dim I As Long

    If MsgBox("Export Selected Sheets To New Workbook", vbYesNo, "NewCopy") = vbNo Then Exit Sub

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
        N = 0
        For Each Ws In ActiveWindow.SelectedSheets
            ReDim Preserve ArrSheetToCopy(N)
            ArrSheetToCopy(N) = Ws.Name
            N = N + 1
        Next Ws
        ThisWorkbook.Sheets(ArrSheetToCopy(0)).Select
    
        With Workbooks.Add
            For I = (.Sheets.Count + 1) To (UBound(ArrSheetToCopy) + 1)
                .Sheets.Add
            Next I
    
            For I = 0 To UBound(ArrSheetToCopy)
                ThisWorkbook.Sheets(ArrSheetToCopy(I)).Cells.Copy
                With .Sheets(I + 1)
                    .Cells.PasteSpecial xlPasteAll
                    .UsedRange.Value = .UsedRange.Value
                    .Name = ThisWorkbook.Sheets(ArrSheetToCopy(I)).Name
                    .DisplayRightToLeft = False
                    .Select: .Range("A1").Select
                End With
            Next I
    
            .SaveAs ThisWorkbook.Path & "\Exported.xlsm", xlOpenXMLWorkbookMacroEnabled
            .Close
        End With
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True

    MsgBox "Done...", 64
End Sub

إعداد / ياسر خليل أبو البراء

هناك 13 تعليقًا:

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

    ولكني جربت هذا الكود على اوفيس 2016 وحدثت مشكلة ، لانني نقلته الي ملف اخر ، فهل هذه هي المشكلة ، ام انها سوف تعمل مع كل الملفات ومع تغيير او اضافة اوراق اخرى للمصنف

    ردحذف
  2. بارك الله فيك أخي الكريم جمال
    ما المشكلة التي تظهر معك ..يرجى النقر على كلمة Debug أثناء حدوث الخطأ ونسخ السطر باللون الأصفر للوقوف على المشكلة حيث أن الكود يعمل لدي في أوفيس 2016 ، وسؤال هل جربت الملف المرفق بالموضوع وهل يعمل معك أم به مشكلة ؟

    ردحذف
  3. سلمت يمينك يا أغلى الناس

    ردحذف
  4. سلمت من كل سوء أخي الكريم ياسر ..تقبل تحياتي

    ردحذف
  5. شكرا لك اخي ياسر المبدع .. وفقك الله لكل خير..
    عند تصدير الصفحة التي هي أساساً من اليمين وكذلك الصفوف من اليمين .. تصدر الى إتجاه اليسار علما أن أتجاه الصفحات عندي من اليمين

    ردحذف
  6. الأمر بسيط جداً غير القيمة في السطر التالي من False إلى True
    .DisplayRightToLeft = False

    ردحذف
  7. أخي ياسر ... الله عليك مبدع ..
    هل من الممكن عمل فورم تحنوي على CheckBox بعدد الصفحات الموجودة في مصنف ..أي ان عدد ال CheckBox يظهر بعدد الصفحات الموجودة مثلا 20 أو 30 أو 50 أو أكثر .. بحيث يظهر الفورم فيه إسم الصفحة ويقبلها CheckBox إذا أردنا إختيار صفحات محددة وتصديرها الى مصنف جديد كما في الكود الرائع الذي عملته .. وهل من الممكن عمل إضافي يقوم بتحويل الصفحات المختارة بصيغة PDF ... مع شكري وتقديري

    ردحذف
  8. السلام عليكم اخي ياسر
    اريد فقط تغيير في الكود لجعله يحفظ بنفس اسم المصنف او الملف مع اضافة كلمة "جداول" قبلها
    وجزاك الله عنا كل خير

    ردحذف
  9. وعليكم السلام
    جرب هذا السطر
    .SaveAs ThisWorkbook.Path & "\جداول " & ThisWorkbook.Name & ".xlsm", xlOpenXMLWorkbookMacroEnabled

    ردحذف
  10. تم تجربته وهي صحيحة ، ولكن اضاف كلمة .xlsm
    جداول دراسة جدوى اقتصادية لمشروع.xlsm

    ردحذف
  11. تم تعديله من قبلنا ، وشكرا لك اخي ياسر وبارك الله فيك
    اذا كنت اريد ان اتعلم البرمجة ، وخاصة هذه الاكواد
    اريد تجميعة من الاكواد مجمعة في ملف واحد ، ووظيفة كل منها.
    لانني تعبت جدا علشان هذا الكود الذي اصلحته انت الان ، ورغم سهولتها على ما اظن ، لانني لا اعرف كود تعريف اسم الملف او المصنف

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

    ردحذف