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

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

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

إخواني الكرام ..

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

في الملف المرفق ، تم وضع المصنف المسمى Split Workbook في مجلد .. المصنف يحتوي على  4 أوراق عمل ( الأول Main - الثاني Data - الثالث Search -  الرابع Result)

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

أسطر الكود مشروحة داخل الكود ..

Sub SplitWorkbook()
    'تعريف المتغير من النوع النصي
    Dim xPath As String
    'تعريف المتغير من النوع ورقة عمل
    Dim SH As Worksheet
    'تعيين المتغير لتساوي قيمته مسار المصنف الحالي
    xPath = Application.ActiveWorkbook.Path
    'إلغاء خاصية اهتزاز الشاشة
    Application.ScreenUpdating = False
    'إلغاء خاصية رسائل التنبيه
    Application.DisplayAlerts = False
        'حلقة تكرارية لكل أوراق العمل بالمصنف
        For Each SH In ThisWorkbook.Sheets
            'نسخ ورقة العمل
            SH.Copy
            'حفظ ورقة العمل بنفس الاسم ونفس المسار
            Application.ActiveWorkbook.SaveAs Filename:=xPath & "\" & SH.Name & ".xlsm", FileFormat:=xlOpenXMLWorkbookMacroEnabled
            'إغلاق المصنف الجديد والذي أصبح هو المصنف النشط
            Application.ActiveWorkbook.Close False
        'الانتقال لورقة العمل التالية
        Next
    'تفعيل خاصية رسائل التنبيه
    Application.DisplayAlerts = True
    'تفعيل خاصية اهتزاز الشاشة
    Application.ScreenUpdating = True
End Sub

* ملحوظة : يجب ألا تكون هناك ورقة عمل بنفس اسم المصنف Split Workbook ، حتى لا يحدث مشكلة أثناء تنفيذ الكود

أو لتجنب هذه المشكلة يمكن إضافة هذا السطر

On Error Resume Next

أرجو أن ينال الملف رضاكم ، وتستفيدوا منه في المقام الأول ...

دمتم في رعاية الله وطاعته ..

 

وهذا رابط لقناتي على اليوتيوب (في انتظار آرائكم حول القناة كبداية لمرحلة جديدة ..)

My Channel

أخوكم أبو البراء من منتدى أوفيسنا

حمل الملف من هنا

[ابو القبطان]

حبيبنا الغالي : ياسر خليل 

وددت اهنأك على قناتك الجديده ( ياترى دي من نتاج المؤتمر الاقتصادي ؟؟ ) 

بس فكرة الملف في منتهى الروعة 

تقبل تحياتي 

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

السلام عليكم

 

جزاكم الله خيرا

تقبلوا تحياتي وشكري

[عادل ابوزيد]

الاستاذ ياسر

ابداع ورا ابداع

ما شاء الله عليك زادك الله من علمه وفضله واحسانه

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

الأخ الغالي أبو القبطان ..

مكشور على مرورك الكريم

مقلتش رأيك في القناة ؟ دي ولا القناة الأولى بتاعت زمان

 

الأخ والحبيب والأستاذ عبد الله

مشكور على مرورك العطر ، وجزيت خيراً بمثله

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

الأخ الغالي عادل أبو زيد

مشكور على إطرائك الجميل .. بارك الله فيك وزادك من علمه ...

وفي انتظار مساهماتك الفعالة

[نايف - م]

شكرا للأبداع المتجدد

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

السلام عليكم

كود مقيد ، و فعال

جزاكم الله خيرا

 

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

 

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

 

و مبروك على القناة و ان شاء الله فاتحة خير 

[دغيدى]

كود جميل .. بارك الله فيكم

[أبو إيمان]

جزاكم الله خيرا 

عاوزين بعد الانشطار اللي حصل دا 

نعمل اندماج وتأليف بين المصنفات المختلفة

[الصـقر]

استاذى الحبيب ابوالبراء

كنت منتظر خطوة القناه دى من فترة كبيرة والحمد لله ومشيئته تم ذالك

الطريق طويل

وفقك الله واعانك  دقيقه من الفيديو توصل المعلومه افضل من شرح كتابى فى 100 صفحه 

بارك الله فيك وزادك علما ونفع بك وجعل اعمالك فى ميزان حسناتك 

(حته على جنب متنساش الاخ رفيع والاستاذ بتاع المزيكا هههههههههههههههههههههه دى كانت السبب  فى بداية حلقات افتح الباب  الحياه مش كلها جد لازم برضوا اى حاجه طريه ولا ايه؟  )

جزاكم الله اخيرا 

[ابراهيم الحداد]

بارك الله فيك . بداية مبشرة وان شاء الله تكون تكون قناة رائعة تليق بروعة صاحبها

فسر على بركة الله وننتظر منك المزيد

تم تعديل مارس 15, 2015 بواسطه زيزو العجوز

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

بسم الله ما شاء الله ..

الانشطار عمل تفاعل كبير كدا ...أنا ممتن لكم إخواني الكرام مروركم العطر وتشجيعكم المستمر لي .

 

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

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

المكتبة غير مفعلة من فترة ، ولكن أنتوي إكمالها بإذن الله خصوصاً أننا قطعنا شوطاً كبيراً فيها .. وهمتك معانا بردو ، في انتظار آرائكم واقتراحاتكم ..

 

الأخ الغالي دغيدي .. بارك الله فيك وجزيت خيراً على مرورك العطر

الأخ الحبيب أبو إيمان .. أنا أعمل إنشطار قوم إنت حالاً واعمل اندماج (أنا أفركش وإنت جمع اللي أنا فركشته ..كل واحد يعمل حاجة)

 

الأخ الحبيب زيزو العجوز ..مشكور على مرورك العطر ، وإن شاء الله بعون الله هناك المزيد وكل يوم جديد وكله بحول الله مفيد

 

الأخ اللي مش فاكر اسمه ..الأخ الحبيب حسام عيسى (فينك غطساااااان بقالك فترة .. لا صباح ولا مسا ولا كلمة كويسة )

مشكور على مرورك العطر ، وبارك الله فيك

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

 

تحياتي القلبية لكم جميعاً إخواني في الله

تم تعديل مارس 15, 2015 بواسطه YasserKhalil

[أبو إيمان]

بسم الله ما شاء الله ..

 

الأخ الحبيب أبو إيمان .. أنا أعمل إنشطار قوم إنت حالاً واعمل اندماج (أنا أفركش وإنت جمع اللي أنا فركشته ..كل واحد يعمل حاجة)

 

 

 

أستاذنا الفاضل  بيقولوا في الأمثال اللي حضر عفريت يصرفه

وحضرتك اللي عملت الانشطار " حضرت العفريت "  يبقى حضرتك تعمل لنا الاندماج "تصرف العفريت "

وصباح الصباح واللي جاي أحسن من اللي راح

[عاطف عبد العليم محمد]

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

جزاكم الله خيرا 

كيف يمكن الاستفادة من  هذا الانشطار ؟

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

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

الأخ أبو إيمان

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

 

الأخ عاطف ..

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

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

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

السلام عليكم

أخي ياسر

هذا هو القسم الذي أقصده

http://www.officena.net/ib/index.php?app=downloads&showcat=16

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

أخي الحبيب محمد طاهر ..

رغم وجودي بالمنتدى منذ فترة طويلة .. هذه أول مرة أطلع على هذا القسم

عموماً ما أطمح إليه هو ملف كبير وضخم يضم أكواد من هنا وهناك ..كالذي على هذا الرابط

http://www.officena.net/ib/index.php?showtopic=57935&hl=

 

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

[شوقي ربيع]

السلام عليكم

اخي ياسر

جزاك الله خيرا على هذا الكود

الف مبروك القنات وان شاء الله تكون منبر من منابر تعلم الاكسل

 

الأخ أبو إيمان

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

 

متخفش اخوك شوقي موجود جنبك يصرف معاك 1000 عفريت

هذه محاولة مني كبداية لجمع اول شيت من عدت ملفات اكسل من اي مجلد من على الجهاز في ملف اكسل واحد بحيث تكون اسماء الشيتات على اسماء تلك الملفات المجمعة

الاندماج بعد الانشطار

الكود مقسم الى قسمين

القسم الاول يقوم بفتح نافذة لاختيار مجلد من الجهاز

Function ChoixDossier()
    If Val(Application.Version) >= 10 Then
       With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = ActiveWorkbook.Path & "\"
        .Show
        If .SelectedItems.Count > 0 Then
           ChoixDossier = .SelectedItems(1)
        Else
           ChoixDossier = ""
        End If
       End With
     Else
       ChoixDossier = InputBox("Répertoire?")
     End If
End Function

القسم الثاني وهو قسم الدمج

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

ثم تفتح الملفات واحد تلو الاخر مع نسخ محتوى الشيت الاول لكل ملف

ثم لصق ما تم نسخه في شيت جديد في الملف الرئيسي مع اعطاء اسم الملف الى ذلك الشيت الجديد

هذا كل ما في الامر

Sub Affiche()
    Dim wb1 As Workbook, wb2 As Workbook
    Dim sPaNam As String
        Set wb1 = ActiveWorkbook
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

  For Each F In dossier.Files
        If UCase(Right(F.Name, 4)) = "XLSM" Then
        If UCase(Left(F.Name, 2)) <> "~$" And F.Name <> ThisWorkbook.Name Then
        sPaNam = xPath & "\" & F.Name
        Dim bT As Byte: bT = InStr(F.Name, ".xlsm") - 1
        Dim sName As String: sName = Left(F.Name, bT)
        Set wb2 = Workbooks.Open(sPaNam)
        wb2.Sheets(1).Copy Before:=wb1.Sheets(1)
        ActiveSheet.Name = sName
        wb2.Close SaveChanges:=False
        
        Set wb2 = Nothing

        End If: End If
  Next
    Set wb1 = Nothing
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

اما هذا الكود

Sub Agrégation()
  xPath = ChoixDossier()
  If xPath = "" Then Exit Sub
  Set Fs = CreateObject("Scripting.FileSystemObject")
  Set dossier = Fs.getfolder(xPath)
  Affiche
End Sub

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

حيث في الاول نمسك بمسار المجلد المختار

ثم قمنا بتعريف المتغير Fs على انه ملف

اما المتغير dossier  تم تعريفه على انه مجلد

تحياتي للجميع

 

الملف الرئيسي الذي يحوي الاكواد هو الملف المسمى ب compilation de fichier

Plusieurs fichiers en une seule compilation de fichier.rar

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

الأخ الحبيب شوقي ربيع

بارك الله فيك وجزاك الله كل خير على المساندة الكبيرة ..

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

http://www.officena.net/ib/index.php?showtopic=59815

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

[أبو إيمان]

جزاكم الله خيرا جميع من هنا تأتي الابداعات

[جلال الجمال_ابو أدهم]

اخى / ياسر 

بارك الله فيك

مفرقعاتك قمه فى المعرفه

تحياتى يا نوبل

[عاطف عبد العليم محمد]

الأخ أبو إيمان

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

 

الأخ عاطف ..

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

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

جزاك الله خيرا   اخي ياسر وفقكم الله 

[احمد حبيبه]

بصراحة ملف رائع ...جزاك الله خيرا

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

ولتكن الصفحة النشطة

جزاك الله عنا خيرا

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

أخي الكريم أحمد حبيبة

جرب الكود التالي ..يمكنك تغيير اسم ورقة العمل في السطر المشار إليه في التعليق

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

تقبل تحياتي