الانشطار الأكبر ( the biggest splitting )

[مختار حسين محمود]

بسم الله الرحمن الرحيم


والصلاة والسلام على أول الأنبياء وخاتم المرسلين سيدنا محمد ( صلى الله عليه وسلم  ) صلاةً الى يوم الدين

إخوانى وأحبابى وزملائى  وأساتذتى فى منتدانا أوفيسنا السلام عليكم ورحمة الله وبركاته
 
أما بعد

 

بداية أوجه شكرى لأستاذى ياسر خليل على موضوعه 

 

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

 

في هذا الرابط

http://www.officena....showtopic=59788  

 

واليوم  أقدم لكم موضوعى  الانشطار الأكبر  أو  the biggest splitting 

 

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

 

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

 

فكلما قل عدد الصفوف كلما زاد عدد المصنفات الناجمة عن هذه العملية

 

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

 

والمصنفات الناجمة عن الانشطار تتكون فى مجلد يتم تكوينه أثناء هذه العملية

 

وعلى رأى أستاذى ياسر  " اللى يحضر عفريت يصرفه "

 

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

 

استخدمت فى عملية التجميع كود أستاذنا ياسر خليل بعد اجراء تعديلات تتناسب مع الهدف .

 

الأكواد المستخدمة :

 

الكود الأول المسئول عن عملية الانشطار لــ  Jerry Beaucaire :

Option Explicit

Sub SplitFileByNRows()
'Jerry Beaucaire  7/27/2014

 'تعريف المتغيرات فى الكود
Dim N As Long, T As Long, LR As Long, Rw As Long, Cnt As Long
Dim IncludeTitles As Boolean, fPATHOUT As String, Titles As Range

'تحديد عدد الصفوف التى سوف تنسخ فى كل ملف جديد
N = Application.InputBox("How many rows to copy into each new workbook?", "Rows Per", 100, Type:=1)
If N = 0 Then Exit Sub     ' اذا كانت القيمة = 0  يتم الالغاء

'  نحديد تضمين العنوان أو رأس الصفحة  فى الملف الجديد أم لا
IncludeTitles = MsgBox("Include titles in each new workbook?", vbYesNo)

'تحديد عدد الصفوف التى سوف تنسخ ابتداء من أعلى الصفحة اذا ما تم تضمين العنوان أو راس الصفحة
If IncludeTitles Then         'اذا تم تضمين العنوان أو رأس الصفحة
    Do         'افعل  العمل التالى
        T = Application.InputBox("How many rows from the top makeup the titles to be included in each new workbook?", "Title Rows", 1, Type:=1)
        'فرصة اعادة ادخال البيانات اذا تم ادخال 0 أو ضغط الغاء أو تخطى الاجراءات
        If T = 0 Then
            If MsgBox("There are no title rows to include after all?" & vbLf & _
                      "(click YES if made a mistake and would you still like to include title row(s).", vbYesNo) = vbNo Then
                IncludeTitles = False  ' الغاء تضمين  العنوان أو رأس الصفحة
                Exit Do
            End If
        Else
            Exit Do
        End If
    Loop
End If

'انشاء مجلد جديد فى نفس مسار الملف النشط وذلك لوضع الملفات الجديدة بداخله
fPATHOUT = ActiveWorkbook.Path & Application.PathSeparator & "OUTPUT" & Application.PathSeparator
If Len(Dir(fPATHOUT, vbDirectory)) = 0 Then
    On Error Resume Next
    MkDir fPATHOUT
    On Error GoTo 0
Else
'فحص الملفات الجديدة داخل المجلد الجديد واعطاء خيار الحذف أو تركها
    If Len(Dir(fPATHOUT & "*.xl*")) > 0 Then
        If MsgBox("There are currently files inside the folder:" & vbLf & "    " & fPATHOUT & vbLf & vbLf & _
        "If we continue, those files will be erased and new files placed in that folder. Are you sure you want to proceed?" _
        & vbLf & vbLf & "(Click NO if you want to abort and copy those files to a safe location)", vbYesNo) = vbYes Then
            Kill (fPATHOUT & "*.xl*")
        Else
            Exit Sub
        End If
    End If
End If

'عملية معالجة الشيت النشط
 'إلغاء خاصية اهتزاز الشاشة
Application.ScreenUpdating = False
With ActiveSheet
    If IncludeTitles Then Set Titles = .Range("A1").Resize(T).EntireRow
    LR = .Range("A" & .Rows.Count).End(xlUp).Row
    For Rw = T + 1 To LR Step N
        Cnt = Cnt + 1      'زيادة قيمة المتغير بمقدار 1
        Sheets.Add   ' اضافة شيت جديد
        If IncludeTitles Then
            Titles.Copy Range("A1")
            .Range("A" & Rw).Resize(N).EntireRow.Copy Range("A" & T + 1)
            Range("A" & T + 1).Select
            ActiveWindow.FreezePanes = True
        Else
            .Range("A" & Rw).Resize(N).EntireRow.Copy Range("A1")
        End If
        ActiveSheet.Move        '  تحريك الملف النشط
          'حفظ ورقة العمل النشطة باسم  كذا وفى نفس المسار
        ActiveWorkbook.SaveAs fPATHOUT & "NewBook" & Cnt & ".xlsx", 51
        ActiveWorkbook.Close False  ' الغاء اغلاق الملف النشط
    Next Rw         'الانتقال للصفوف التالية
End With
 'تفعيل خاصية اهتزاز الشاشة
Application.ScreenUpdating = True
MsgBox "A total of " & Cnt & " new workbooks were created and can be found in:" & vbLf & fPATHOUT

End Sub

الكود الثانى الخاص بعملية التجميع " مقبس من كود التجميع لدى أستاذى ياسر خليل مع اجراء تعديلات واضافات " :

Option Explicit

Sub CollectWorkbooks()

    'تعريف المتغير من النوع نصي
     Dim Path As String
     
     'تعريف المتغير من النوع نصي
     Dim Filename As String
     
     'تعريف المتغير من النوع ورقة عمل
     Dim SH As Worksheet
     
     Dim wrkConsSheet As Worksheet
    
     Dim lngLastRow As Long
     
     Dim lngOutputRow As Long
      
     Dim lngMyCounter As Long
      
     Dim shp As Shape
     
     'تعريف المتغير للترتيب الصحيح لأوراق العمل
     Dim X As Long
     
     'تعيين القيمة 1 للمتغير كبداية
     X = 1
     
     'تعيين المتغير ليساوي مسار المجلد الذي يحوي المصنفات المراد دمج أوراق العمل منها
     Path = ThisWorkbook.Path & "\OUTPUT\"
     
     'تعيين المتغير ليساوي اسم كل مصنف من المصنفات التي سيتم التعامل معها
     Filename = Dir(Path & "*.xlsx")
     
     'إلغاء خاصية اهتزاز الشاشة
     Application.ScreenUpdating = False
     
     'إلغاء خاصية التنبيه بالرسائل
     Application.DisplayAlerts = False
     
     '[StartingData]حلقة تكرارية لحذف أوراق العمل ما عدا الورقة المسماة
      For Each SH In ThisWorkbook.Sheets
      If SH.Name <> "FINISHING DATA" Then SH.Delete
       Next SH
      
      ThisWorkbook.Worksheets("FINISHING DATA").Select
      Selection.ClearContents
     
     'حلقة تكرارية للمصنفات الموجودة في المسار المحدد إلى أن لا يجد أي مصنف بالمسار
      Do While Filename <> ""
     'فتح المصنف
      Workbooks.Open Filename:=Path & Filename, ReadOnly:=True
     
     'حلقة تكرارية لكل أوراق العمل داخل المصنف النشط
      For Each SH In ActiveWorkbook.Sheets
     
     'نسخ ورقة العمل ولصقها بنهاية فهرس أوراق العمل
      SH.Copy After:=ThisWorkbook.Sheets(X)
     
     'زيادة قيمة المتغير بمقدار 1
      X = X + 1
     
     'الانتقال لورقة العمل التالية
      Next SH
     
     'إغلاق المصنف
      Workbooks(Filename).Close
     
     'إعادة ضبط المتغير
      Filename = Dir()
      Loop
      
     'تنشيط أو تحديد ورقة العمل الأولى
      Sheets("FINISHING DATA").Activate
     
      Application.ScreenUpdating = False
     
      Set wrkConsSheet = Sheets("FINISHING DATA")    'اعتبار المتغير wrkConsSheet = ورقة العمل [FINISHING DATA]
      
      ' مرحلة البحث والتجميع
      For Each SH In ThisWorkbook.Sheets
      
      If SH.Name <> "FINISHING DATA" Then
      lngLastRow = SH.Range("A:Z").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
      If lngMyCounter = 0 Then
      SH.Range("A1:Z" & lngLastRow).Copy Destination:=wrkConsSheet.Range("A1")
      Else
      lngOutputRow = wrkConsSheet.Range("A:Z").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1
      SH.Range("A2:Z" & lngLastRow).Copy Destination:=wrkConsSheet.Range("A" & lngOutputRow)
      End If
      lngMyCounter = lngMyCounter + 1                 'زيادة قيمة المتغير بمقدار 1
      End If
      Next SH
      Sheets("FINISHING DATA").Activate              'تنشيط أو تحديد ورقة العمل [FINISHING DATA]
      
      For Each SH In ThisWorkbook.Sheets
      If SH.Name <> "FINISHING DATA" Then SH.Delete ' حذف أوراق العمل ما عد الورقة المسماه[FINISHING DATA]
      
      Next SH
           
      For Each shp In ActiveSheet.Shapes
      If shp.Top > 150 Then shp.Delete  ' لحذف الأشكال التلقائية التى  تنسخ أثناء عملية الانشطار والتجميع
      Next

     
      'تفعيل خاصية التنبيه بالرسائل
      Application.DisplayAlerts = True
     
     'تفعيل خاصية اهتزاز الشاشة
     'Application.ScreenUpdating = True
     
     
   
     
End Sub

المرفق يحتوى مصنفين : الأول الذى نجرى عليه عملية الانشطار والثانى وهو الذى تتم فيه عملية التجميع

 أتمنى أن تسعدوا به و لكم منى كل محبة وتقدير واحترام
 
 
والحمد لله تعالى من قبل ومن بعد

***************

 

the biggest splitting.rar

تم تعديل مارس 24, 2015 بواسطه مختار حسين محمود

[عبد العزيز البسكري]

بارك الله فيك و جزاك الله خيرا .. لما تقدّمه من أفكار و مواضيع أستاذي القدير

[أبو إيمان]

تسلم يداك

جاري التجربة

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

الأخ الحبيب مختار

بارك الله فيك وجزاك الله خير الجزاء في الدنيا والآخرة ..

بصراحة هو دا الشغل اللي على كبير يا كبير ..

خلي بالك احتمال يجيلك خبر قريب انضمامك للهيئة الدولية للطاقة النووية .. بس متنسناش ساعتها بدعوتين (دعوة بظهر الغيب ودعوة لحضور تكريمك هناك)

تقبل تحياتي

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

ملف الانشطار 10 / 10 ..بس ملف التجميع بيجمع البيانات بشكل غير اللي كان عليه في البداية ..عايزين كل حاجة ترجع لطبيعتها !!

[مختار حسين محمود]

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

أخى أبو ايمان بارك الله فيكم  وجازاكم خيرا

=========

أستاذى وأخى ياسر خليل هذا بعض ما عندكم  بفضل  تشجيعك المستمر

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

  متفائل أقوى صح ؟!   لكن كلى أمل   غداً أو غداً

بالنسبة لملف التجميع :
 
لوكان عدد المصنفات الناجمة عن الانشطار أقل من 10 هتلاقى البيانات مظبوطة كما  كانت فى ورقة العمل " STARTTING DATA"

ولو زادت عن 10 يحدث هذا الاختلاف    ليــــــــــــــــــــــــــــــه ؟
لأن أثناء عملية تجميع أوراق العمل من المصنفات المنشطرة  فى المجلد  OUTPUT  ترتب الأوراق حسب الاسم
 
فتلاقى الورقة 1    وبعدها الورقة 10   وبعدها الورقة 2    ثم الورقة 3    ثم .................... الخ

وعندما تبدأ عملية تجميع البيانات من هذه الأوراق تبدأ من الورقة 1  ثم من الورقة   10    ثم من الورقة 2    ثم من الورقة 3

وهكذا على التوالى الى أن تنتهى عملية تجميع البيانات بحذف هذه الأوراق باستثناء  "FINISHING DATA"

 

تحياتى لك ولكل الزملاء