اذهب الي المحتوي
أوفيسنا

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


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

في ‏٢١‏/‏٠٣‏/‏٢٠١٦ 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

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

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

رابط هذا التعليق
شارك

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

تقبل تحياتي

رابط هذا التعليق
شارك

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

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

 

الاستخراج.rar

رابط هذا التعليق
شارك

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

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

رابط هذا التعليق
شارك

  • 3 weeks later...

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

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

SH.UsedRange.Value = SH.UsedRange.Value
           

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

رابط هذا التعليق
شارك

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

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

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

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

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

تقبل تحياتي

رابط هذا التعليق
شارك

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

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

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

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

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

رابط هذا التعليق
شارك

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

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

رابط هذا التعليق
شارك

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

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

Split Workbook Into Multiple Workbooks1.rar

  • Like 1
رابط هذا التعليق
شارك

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

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

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

 

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

تقبل تحياتي

رابط هذا التعليق
شارك

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

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

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

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

تقبل تحياتي

  • Like 1
رابط هذا التعليق
شارك

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

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

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

رابط هذا التعليق
شارك

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

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

Application.EnableEvents = False

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

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

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

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

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

Application.ActiveWorkbook.Close True

 

  • Like 1
رابط هذا التعليق
شارك

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

strName =SH.CodeName
            With ActiveWorkbook.VBProject.VBComponents(strName).CodeModule
                .DeleteLines 1, .CountOfLines
            End With
رابط هذا التعليق
شارك

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

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

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

 

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

الرابط من هنا

تقبل تحياتي

  • Like 1
رابط هذا التعليق
شارك

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

3.jpg

  • Like 1
رابط هذا التعليق
شارك

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

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

الرابط من هنا

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

  • Like 1
رابط هذا التعليق
شارك

  • 11 months later...
في ٢٠‏/٣‏/٢٠١٦ 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"))

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

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

 

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

السلام عليكم

 

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

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

 

  • Like 2
رابط هذا التعليق
شارك

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

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

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

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

رابط هذا التعليق
شارك

السلام عليكم

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

و قد اخترته 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

 

رابط هذا التعليق
شارك

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

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

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

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

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

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

 

رابط هذا التعليق
شارك

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

 

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
  • Like 2
  • Thanks 1
رابط هذا التعليق
شارك

زائر
هذا الموضوع مغلق.
  • تصفح هذا الموضوع مؤخراً   0 اعضاء متواجدين الان

    • لايوجد اعضاء مسجلون يتصفحون هذه الصفحه
×
×
  • اضف...

Important Information