ادراج مجموع كل صفحة & المجموع الكلي

[omar elhosseini]

 

 

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

موضوعنا اليوم اردت ان تكون صيغتة صيغة عامة تخدم الكثير من موضوعات جداول البيانات وهو 

ادراج مجموع كل صفحة وايضا المجموع الكلي

وكنت قد قدمت هذا الموضوع منذ سنوات

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

فبحثت عن الموضوع ولكني لم اجده

ثم بحثت في المنتديات الاجنبية لعلي اجد كود لهذا الموضوع

فلم اجد الا كود واحد فقط يغطى هذا الموضوع

وهو للمبرمج

Ole P. Erlandsen

منذ عام 1999

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

حاولت تطويعة  (  من باب الاستسهال بدلا من كتابة كود جديد  )  ولكن صعب عليا تطويعه 

فتركت الموضوع

ثم امس ومضت لي فكرة بناء كود جديد فتوكلت علي الله

وكانت هذه النتيجة

الكود له 3 مدخلات يجب ضبطها وهي اول 3 سطور في الكود

 

'=========================================
First_Cel = "A1"                                       '  عنوان اول خلية في جدول البيانات
Count_Row_In_Page = 10                     '  عدد الصفوف في كل صفحة
Col_Total = "E"                                        '  عمود المجموع
'=========================================

 

انظر المرفقات

 

الكود

Option Base 1

Sub Subtotals_For_Each_Page()
'
'=======================================================================
First_Cel = "A1"                            ' عنوان اول خلية في جدول البيانات
Count_Row_In_Page = 10                      ' عدد الصفوف في كل صفحة
Col_Total = "E"                             ' عمود المجموع
'=========================================
Ttitle_1 = "اجمالـــي صفحـــة"
Ttitle_2 = "اجمالـــي الصفحـــات :"
'=======================================================================
ScreenOff
Dim Sh_Total_Page As Worksheet
Dim Rng As Range
Dim Arr()
Dim Arr_Page()
'=======================================================================
ActiveSheet.ResetAllPageBreaks
Maximum_Row = ActiveSheet.HPageBreaks(1).Location.Row - 3
If Count_Row_In_Page < 1 Or Count_Row_In_Page > Maximum_Row Then MsgBox "عدد الصفوف لكل صفحة من  1 الي    " & Maximum_Row: Exit Sub
'=======================================================================
Set Sh_Total_Page = Sheets("مجموع_الصفحات")
First_Col = Range(First_Cel).Column
Count_Col = Cells(Range(First_Cel).Row, Columns.Count).End(xlToLeft).Column
End_Row = Cells(Rows.Count, First_Col).End(xlUp).Row
Set Rng = Range(First_Cel).Offset(1)
Set Rng = Range(Rng, Cells(End_Row, Count_Col))
Arr = Rng
'=======================================================================
With Sh_Total_Page
    .Cells.Delete Shift:=xlUp
    Range(Range(First_Cel), Cells(Range(First_Cel).Column, Count_Col)).EntireColumn.Copy
    .Range("A1").Insert Shift:=xlToRight
    .Rows(Range(First_Cel).Offset(1).Row & ":" & Rows.Count).ClearContents
End With
'=======================================================================
Page_Counter = 1
Grand_Total = 0
Col_Total = Columns(Col_Total).Column
For x = LBound(Arr) To UBound(Arr) Step Count_Row_In_Page
    ReDim Arr_Page(Count_Row_In_Page + 1, Count_Col)
    Row_Offset = x
    Total_Page = 0
    For Row = 1 To Count_Row_In_Page
        Col_Counter = 0
        Total_Page = Total_Page + Arr(Row_Offset, Col_Total)
        For Col = 1 To Count_Col
            Col_Counter = Col_Counter + 1
            Arr_Page(Row, Col_Counter) = Arr(Row_Offset, Col_Counter)
        Next
        Row_Offset = Row_Offset + 1
        On Error Resume Next
    Next
    Grand_Total = Grand_Total + Total_Page
    '=======================================================================
    Arr_Page(Count_Row_In_Page + 1, 1) = Ttitle_1 & Page_Counter & " : "
    Arr_Page(Count_Row_In_Page + 1, Col_Counter) = Total_Page
    Page_Counter = Page_Counter + 1
    '=======================================================================
    With Sh_Total_Page
        End_Row = .Cells(Rows.Count, "A").End(xlUp).Row + 1
        Set Rng = .Cells(End_Row, "A")
        Set Rng = Rng.Resize(Count_Row_In_Page + 1, Col_Total)
        Rng = Arr_Page
        End_Row = .Cells(Rows.Count, "A").End(xlUp).Row + 1
        Range(.Cells(End_Row - 1, 1), .Cells(End_Row - 1, Count_Col)).Font.Bold = True
        Range(.Cells(End_Row - 1, 1), .Cells(End_Row - 1, Count_Col)).Font.ColorIndex = 5
    End With
    Erase Arr_Page
Next
With Sh_Total_Page
    End_Row = .Cells(Rows.Count, "A").End(xlUp).Row + 1
    .Cells(End_Row, "A") = Ttitle_2
    .Cells(End_Row, Col_Total) = Grand_Total
    Range(.Cells(End_Row - 1, 1), .Cells(End_Row, Count_Col)).Font.Bold = True
    Range(.Cells(End_Row - 1, 1), .Cells(End_Row, Count_Col)).Font.ColorIndex = 5
    Range(.Cells(End_Row, 1), .Cells(End_Row, Count_Col)).Font.ColorIndex = 3
    .Select
End With
'=======================================================================
Every_Row = Count_Row_In_Page + 1
With ActiveSheet
    .ResetAllPageBreaks
    TotalPageBreaks = ActiveSheet.HPageBreaks.Count
    Lastrow = .Cells(Rows.Count, "A").End(xlUp).Row
    For Row_Index = Every_Row + 2 To Lastrow Step Every_Row
        If Row_Index = Lastrow Then
            .HPageBreaks.Add Before:=.Cells(Row_Index + 1, 1)
        Else
            .HPageBreaks.Add Before:=.Cells(Row_Index, 1)
        End If
    Next
End With
TotalPageBreaks = ActiveSheet.HPageBreaks.Count
ActiveSheet.HPageBreaks(TotalPageBreaks).Delete
'=======================================================================
End_Row = Cells(Rows.Count, "A").End(xlUp).Row
Set Rng = Range(Range(First_Cel), Cells(End_Row, "A"))
Rng.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
With Sh_Total_Page.PageSetup
    .PrintTitleRows = "$1:$1"
End With
End_Row = Cells(Rows.Count, "A").End(xlUp).Row + 1
Rows(End_Row & ":" & Rows.Count).Delete Shift:=xlUp
On Error GoTo 0
'=======================================================================
ScreenOn
'
End Sub

 

المرفقات

 

ادراج مجموع كل صفحة & المجموع الكلي.rar

 

 

[ناصر سعيد]

ايه الروعه دي

ايه الجمال ده

ربنا يبارك لك يا استاذ عمر الحسيني

[omar elhosseini]

انت دائما حظك في رجليك اخي العزيز

[سليم حاصبيا]

اكثر من رائع

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

بارك الله فيك أخي الغالي أبو تامر وجزيت خير الجزاء

تقبل الله منا ومنكم صالح الأعمال وكل عام وأنت بخير

تقبل وافر تقديري واحترامي

 

[محي الدين ابو البشر]

السلام عليكم

يا أخي

بارك الله بك وبجهودك

رائع رائع رائع

أدامك الله وسر خاطرك

[علي حيدر]

جميل والله بارك اللع فيك

[omar elhosseini]

 

الاخوة الاعزاء

سليم حاصبيا

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

محي الدين

ali haidar

بارك الله فيكم الاخوة الاعزاء

 

[مهند الزيدي]

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

اذا اردنا ان يكون المجموع ليس للعمود E فقط ولكن مثلا للعمود من B الى E  أو أعمدة متفرقة حسب الحاجة .. وشكرا لكل أخي العزيز مرة أخرى

[omar elhosseini]

 

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

تم التعديل حسب طلبك 

الان يمكنك ان يكون المجموع ليس للعمود E فقط ولكن مثلا للعمود من B الى E أو أعمدة متفرقة حسب الحاجة 

ويجب تعديل المعطيان داخل الكود

 

'=========================================
First_Cel = "A1"                                       '  عنوان اول خلية في جدول البيانات
Count_Row_In_Page = 10                     '  عدد الصفوف في كل صفحة
Arr_Col_Total = Array(12, 5, 3)                         ' ارقام اعمدة المجموع بالنسبة الي الجدول وليس الأكسل
'=========================================

تم تعديل بعض الاخطاء في النسخة الاولي

فقط كانت لا تعمل اذا كان الجدول لا بيدأ من اول عمود

 

ادراج مجموع كل صفحة & المجموع الكلي_2.rar

 

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

رائع أخي الغالي أبو تامر

لا حرمنا الله من إبداعاتك ... إنك بحق متميز

 

[saad abed]

اخى عمر

ابداعاتك متعدده ررررررررررررررررررررائئئئئئئئئئئئع

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

وفقكم الله

[omar elhosseini]

 

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

شكرا لك اخي

الاخ سعد عابد

شكرا لك اخي

 

اضافة بسيطة الي الملف لتسهيل تعديل مدخلات الجدول

 

ادراج مجموع كل صفحة & المجموع الكلي_3.rar

 

[مهند الزيدي]

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

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

عمر الحسيني

اخى الفاضل ما شاء الله عليك

[عبدالله المجرب]

بصراحة كود قمة في الاتقان والتميز 

سلمت يمينك استاذ عمر الحسيني 

 

وعوداً حميداً ومميزا كالعادة 

 

[omar elhosseini]

 

الاخ القدير عبدالله المجرب

شكرا لك اخي العزيز

 

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

أستاذ عمر السلام عليكم

كود بل هديه رائعة من أستاذ أروع

كم أحب مثل هذه الأكواد ؟!   تحياتى

 

[محي الدين ابو البشر]

السلام عليكم

بارك الله بك وبجهودك

و

أفكارك النيرة

فعلا جميل جداً

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