الإنشطار الكبير .. انشطار أوراق المصنف إلى مصنفات منفصلة

احمد حبيبه · أبريل 6, 2016

في ‏٢١‏/‏٠٣‏/‏٢٠١٦ at 04:41, ياسر خليل أبو البراء said:
أخي الكريم أحمد حبيبة

جرب الكود التالي ..يمكنك تغيير اسم ورقة العمل في السطر المشار إليه في التعليق
Sub SplitSpecificSheet()
    Dim xPath As String
    Dim SH As Worksheet
    xPath = Application.ActiveWorkbook.Path
    Set SH = Sheets("Data") 'غير اسم ورقة العمل المراد تصديرها
    
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
        With SH
            .Copy
            Application.ActiveWorkbook.SaveAs Filename:=xPath & "\" & .Name & ".xlsm", FileFormat:=xlOpenXMLWorkbookMacroEnabled
            Application.ActiveWorkbook.Close False
        End With
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub
تقبل تحياتي

اخى واستاذى الفاضل ....اعذرنى لم ارى ردك الا اليوم ...لى عند حضرتك ثلاث طلبات

الاول ... هل يمكن استخراج الصغحة المطلوبه فى ملف اسمه تصدير

الثانى هل يمكن تغيير امتداد الملف المستخرج الى صيغة xls

الثالث .. هل يمكن ان تكون محتويات الملف المصدر قيم فقط بدون دوال او ارتباطات

اشكرك جدا جدا وادعوا لك دائما بظهر الغيب...تقبل تحياتى

ياسر خليل أبو البراء · أبريل 6, 2016

أخي الكريم أفضل طرح موضوع جديد ترفق فيه ملفك .. وإن شاء الله إذا تيسر لي الوقت سأحاول بالتأكيد العمل عليه

تقبل تحياتي

احمد حبيبه · أبريل 14, 2016

استاذى الفاضل فى الملف المرفق اريد من حضرتك التالى

صفحة data بها دوال ... ارجوا ضبط الكود ليقوم بنسخ القيم فقط دون الدوال في الملف الذى سيخرخ خارج الملف ...كما ارجو استخراج صفحة data داخل الملف المرفق المسمى تصديرات

الاستخراج.rar

ياسر خليل أبو البراء · أبريل 14, 2016

أخي الحبيب أحمد

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

مهند الزيدي · مايو 2, 2016

وفقك الله لك خير أخي ياسر ... وجعله في ميزان حسناتك..

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

SH.UsedRange.Value = SH.UsedRange.Value

وفقك الله للصالحات ... وجميع من في المنتدى

ياسر خليل أبو البراء · مايو 2, 2016

أخي الكريم مهند

من المفترض أن السطر الذي أرفقته يقوم بعمل المطلوب تماماً ويحول المعادلات لقيم وهذا هو الغرض من هذا السطر

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

جرب السطر التالي لعله يفي بالغرض

sh.Cells.Copy
sh.Cells.PasteSpecial xlPasteValues
Application.CutCopyMode = False

تقبل تحياتي

مهند الزيدي · مايو 2, 2016

أخي العزيز ياسر .. شكرا لإستجابتك على طلبي .. لك أمتناني وإحترامي الكثير..

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

For Each SH In ThisWorkbook.Sheets
            SH.Copy
            SH.Cells.Copy
            SH.Cells.PasteSpecial xlPasteValues
     Application.CutCopyMode = False
            Application.ActiveWorkbook.SaveAs Filename:=xPath & "\" & SH.Name & ".xlsm", FileFormat:=xlOpenXMLWorkbookMacroEnabled
            Application.ActiveWorkbook.Close False
        Next

وأرجوا أن أكون قد وفقت في شرح المشكلة .. وجزاك الله خيرا ...,آسف على كثرة الأسئلة ..

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

ياسر خليل أبو البراء · مايو 2, 2016

الكود مش مضبوط تماماً ممكن رابط الموضوع عشان أقدر أحدد المشكلة فين بالضبط أخي الكريم مهند

أعطني رابط الموضوع وضع السطر فقط الذي تظهر فيه المشكلة ... لأضع يدي على المشكلة بالضبط والأفضل كما أخبرتك إرفاق ملف ... لأن الكود بالتأكيد يعمل في الملف المرفق في الموضوع الأصلي ..

مهند الزيدي · مايو 2, 2016

شكرا لك أخي العزيز " ياسر " لا أعرف كيف اجازيك .. ولكن ليس لي سوى الدعاء لك ولوالديك.. أني اتكلم في نفس الموضوع ونفس الملف المرفق عن طريق حضرتك ..سوف أرفق الملف تجنبا لاي اشكال مستقبلا...

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

Split Workbook Into Multiple Workbooks1.rar

ياسر خليل أبو البراء · مايو 2, 2016

جرب السطر التالي بعد سطر Sh.Copy

ActiveWorkbook.ActiveSheet.UsedRange.Value = ActiveWorkbook.ActiveSheet.UsedRange.Value

وأنتظر الرد منك سريعاً لأنني سأنشغل في أمور خاصة بعد قليل

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

تقبل تحياتي

مهند الزيدي · مايو 3, 2016

شكرا لك اخي ياسر وفقك الله لكل خير ..تم المطلوب والحمد لله رب العالمين

وآسف على عدم الرد السريع لظروف خاصة .. رزقك الله الصحة والعافية

ياسر خليل أبو البراء · مايو 3, 2016

أخي العزيز مهند

الحمد لله أن تم المطلوب على خير .. وأعتذر لإلحاحي في طلب الكود أو لرابط الموضوع ..لأنني بالفعل لا أحفظ أكواد على الإطلاق ..إنما يمن الله علي بكتابة كود واقتباس من كود آخر إلى أن يمن الله علي بالانتهاء من الكود المطلوب بالشكل المطلوب وأطرح الحل أو الموضوع وربما أنسى الكثير مما كتبته ... فقد كتبت الكثير لدرجة أنني أنسى أنني كتبت هذا الكود أو ذاك ... والله وحده يعلم بحالي

الحمد لله الذي بنعمته تتم الصالحات ...

وفقني الله وإياك لكل خير

تقبل تحياتي

مهند الزيدي · مايو 3, 2016

أخي العزيز " ياسر " .. اتمنى أن لا اكون أثقلت عليك بطلباتي الكثيرة ..

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

https://yasserkhalilexcellover.blogspot.com/2016/04/export-specific-sheet-to-new-workbook.html

ياسر خليل أبو البراء · مايو 3, 2016

أخي الكريم مهند بالفعل هي نفس الفكرة تماماً لما لا تقوم باستخدامها في الكود لديك

قم بإضافة السطر التالي قبل تنفيذ الكود

Application.EnableEvents = False

وفي نهاية الكود تستخدم نفس السطر مع تحويل القيمة إلى True

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

وستستخدم هذه الأسطر للإشارة إلى ورقة العمل المراد حذف الكود منها

strName = Worksheets("Data").CodeName
            With ActiveWorkbook.VBProject.VBComponents(strName).CodeModule
                .DeleteLines 1, .CountOfLines
            End With

ولا تنسى أيضاً السطر الذي سيقوم بالحفظ

Application.ActiveWorkbook.Close True

مهند الزيدي · مايو 3, 2016

أخي العزيز ياسر . لقد حاولت تطبيق نفس الكود ..ولكن أريد أن يتم حذف الأكواد في أي صفحة وليس فقط الصفحة ( Data) وقد عدلت الكود بهذه الطريقة ولم تنجح ..أرجو التعديل الصحيح .. وفقك الله لكل خير

strName =SH.CodeName
            With ActiveWorkbook.VBProject.VBComponents(strName).CodeModule
                .DeleteLines 1, .CountOfLines
            End With

ياسر خليل أبو البراء · مايو 3, 2016

أخي الكريم مهند

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

من المفترض أن السطر الذي قمت بالتعديل عليه صحيح .. ولكن سؤال هل قمت بالإعلان عن المتغير strName حيث أنه متغير نصي .. قد تكون المشكلة في تلك النقطة

تم شرح الموضوع من جديد بالطلبات الجديدة على الرابط التالي

الرابط من هنا

تقبل تحياتي

مهند الزيدي · مايو 3, 2016

شكرا لك أخي العزيز .. ياسر .. لقد قمت بالإعلان على المتغير strName كما في الكود ..

الصور المرفقة تبين الخطأ ...

مهند الزيدي · مايو 3, 2016

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

ياسر خليل أبو البراء · مايو 3, 2016

الحمد لله الذي بنعمته تتم الصالحات

أكدت مراراً وتكراراً على أن الموضوع في الرابط التالي هو رقم 1 في تعلم الأساسيات وبه بدأت المدونة وكثيراً ما أشير إليه فهو الأساس وفيه تطبيق لما قمت به أي أنه يجب تطبيق الموضوع بشكل جيد .. والتعرف على بيئة محرر الأكواد والأساسيات بشكل عام

الرابط من هنا

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

حسام مصطفي · أبريل 10, 2017

في ٢٠‏/٣‏/٢٠١٦ at 19:41, ياسر خليل أبو البراء said:
أخي الكريم أحمد حبيبة

جرب الكود التالي ..يمكنك تغيير اسم ورقة العمل في السطر المشار إليه في التعليق
Sub SplitSpecificSheet()
    Dim xPath As String
    Dim SH As Worksheet
    xPath = Application.ActiveWorkbook.Path
    Set SH = Sheets("Data") 'غير اسم ورقة العمل المراد تصديرها
    
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
        With SH
            .Copy
            Application.ActiveWorkbook.SaveAs Filename:=xPath & "\" & .Name & ".xlsm", FileFormat:=xlOpenXMLWorkbookMacroEnabled
            Application.ActiveWorkbook.Close False
        End With
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub
تقبل تحياتي

استاذي القدير / ياسر

هل يمكن اختيار اكثر من ورقة ( يتم تحديدهم بمعرفتي ) لنسخها في ملف آخر وتسميته بتاريخ اليوم مثلا

حيث حاولت ان اضع مكان SH هنا السطر

Set SH = Sheets(Array("Data", "Sheet2", "Sheet3"))

ولكن الامر لم يفلح معي .. فما هي المشكلة او الكود الصحيح لتنفيذ ذلك

وهل يمكن النسخ كقيم بدون معادلات

تم تعديل أبريل 10, 2017 بواسطه حسام مصطفي

**محمد طاهر عرفه** · أبريل 11, 2017

السلام عليكم

اذا اردت تكرار الامر علي عدد من اوراق العمل التي تختارها بمعرفتك عن طريق تحديد اسمها ، يمكنك تكرار الجزء الاوسط من الكود كما يلي:

Sub SplitSpecificSheet()
    Dim xPath As String
    Dim SH As Worksheet
    xPath = Application.ActiveWorkbook.Path
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
' Sheet1
    Set SH = Sheets("Sheet1")
        With SH
            .Copy
            Application.ActiveWorkbook.SaveAs Filename:=xPath & "\" & .Name & ".xlsm", FileFormat:=xlOpenXMLWorkbookMacroEnabled
            Application.ActiveWorkbook.Close False
        End With
        
        
  ' Sheet2
            Set SH = Sheets("Sheet2")
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
        With SH
            .Copy
            Application.ActiveWorkbook.SaveAs Filename:=xPath & "\" & .Name & ".xlsm", FileFormat:=xlOpenXMLWorkbookMacroEnabled
            Application.ActiveWorkbook.Close False
        End With

        
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

حسام مصطفي · أبريل 11, 2017

كل الشكر الجزيل لسيادتكم استاذنا الفاضل

وهل يمكن ان يتم نقل الشيتات المختارة كما في الكود لملف واحد معا ( وليس كل شيت لملف منفصل )

وياريت لو بدون معادلات ( قيم فقط )

جزاك الله خيرا استاذنا الكبير

**محمد طاهر عرفه** · أبريل 11, 2017

السلام عليكم

لنقل ورقتي عمل او اكثر لنفس الملف ، هنا اعليك اختيار اسم الملف

و قد اخترته officena على سبيل المثال

Sub SplitSpecificSheet_onefile()
    Dim xPath As String
    xPath = Application.ActiveWorkbook.Path
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    
    Sheets(Array("Sheet1", "Sheet2")).Select
    Sheets(Array("Sheet1", "Sheet2")).Copy
    Application.ActiveWorkbook.SaveAs Filename:=xPath & "\" & "officena" & ".xlsm", FileFormat:=xlOpenXMLWorkbookMacroEnabled
    Application.ActiveWorkbook.Close False

        
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

و لتحويل المعادلات لارفام نضيف جزء جديد


Sub SplitSpecificSheet_onefile()
    Dim xPath As String
    xPath = Application.ActiveWorkbook.Path
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    
    Sheets(Array("Sheet1", "Sheet2")).Select
    Sheets(Array("Sheet1", "Sheet2")).Copy
 
        For k = 1 To ActiveWorkbook.Sheets.Count
           ActiveWorkbook.Sheets(k).Activate
           Cells.Select
           Application.CutCopyMode = False
           Selection.Copy
           Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
               :=False, Transpose:=False
        Next k
    
    Application.ActiveWorkbook.SaveAs Filename:=xPath & "\" & "officena" & ".xlsm", FileFormat:=xlOpenXMLWorkbookMacroEnabled
    

    
    
    Application.ActiveWorkbook.Close False

        
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

حسام مصطفي · أبريل 11, 2017

استاذي القدير

لا اعلم كيف اشكرك علي سرعة ردك وعلي الرد الاكثر من رااائع

وهل يمكن لي ان اطمع في كرم سيادتكم بطلب آخر

بانه اذا كان في الشيتات التي يتم نسخها لشيت جديد معادلات يتم نسخها كقيم فقط في الشيت الجديد

وشكر جزيل الشكر

جزاك الله خيرا استاذنا القدير

**محمد طاهر عرفه** · أبريل 11, 2017

و لتحويل المعادلات لارفام نضيف جزء جديد

Sub SplitSpecificSheet_onefile()
    Dim xPath As String
    xPath = Application.ActiveWorkbook.Path
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    
    Sheets(Array("Sheet1", "Sheet2")).Select
    Sheets(Array("Sheet1", "Sheet2")).Copy
 
        For k = 1 To ActiveWorkbook.Sheets.Count
           ActiveWorkbook.Sheets(k).Activate
           Cells.Select
           Application.CutCopyMode = False
           Selection.Copy
           Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
               :=False, Transpose:=False
        Next k
    
    Application.ActiveWorkbook.SaveAs Filename:=xPath & "\" & "officena" & ".xlsm", FileFormat:=xlOpenXMLWorkbookMacroEnabled
    

    
    
    Application.ActiveWorkbook.Close False

        
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

تسجيل الدخول

الإنشطار الكبير .. انشطار أوراق المصنف إلى مصنفات منفصلة

الردود الموصى بها

Top Posters In This Topic

Popular Days

Top Posters In This Topic

Popular Days

Popular Posts

ياسر خليل أبو البراء

محمد طاهر عرفه

عبدالله باقشير

Posted Images

تصفح هذا الموضوع مؤخراً 0 اعضاء متواجدين الان

Important Information