omar elhosseini قام بنشر يوليو 8, 2016 مشاركة قام بنشر يوليو 8, 2016 السلام عليكم ورحمة الله وبركاتة موضوعنا اليوم اردت ان تكون صيغتة صيغة عامة تخدم الكثير من موضوعات جداول البيانات وهو ادراج مجموع كل صفحة وايضا المجموع الكلي وكنت قد قدمت هذا الموضوع منذ سنوات وقد اعادت هذة الذكري الي ذهني احدي المشاركات منذ ايام قليلة فبحثت عن الموضوع ولكني لم اجده ثم بحثت في المنتديات الاجنبية لعلي اجد كود لهذا الموضوع فلم اجد الا كود واحد فقط يغطى هذا الموضوع وهو للمبرمج 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 9 رابط هذا التعليق شارك More sharing options...
ناصر سعيد قام بنشر يوليو 8, 2016 مشاركة قام بنشر يوليو 8, 2016 ايه الروعه دي ايه الجمال ده ربنا يبارك لك يا استاذ عمر الحسيني رابط هذا التعليق شارك More sharing options...
omar elhosseini قام بنشر يوليو 8, 2016 الكاتب مشاركة قام بنشر يوليو 8, 2016 انت دائما حظك في رجليك اخي العزيز رابط هذا التعليق شارك More sharing options...
سليم حاصبيا قام بنشر يوليو 9, 2016 مشاركة قام بنشر يوليو 9, 2016 اكثر من رائع رابط هذا التعليق شارك More sharing options...
ياسر خليل أبو البراء قام بنشر يوليو 9, 2016 مشاركة قام بنشر يوليو 9, 2016 بارك الله فيك أخي الغالي أبو تامر وجزيت خير الجزاء تقبل الله منا ومنكم صالح الأعمال وكل عام وأنت بخير تقبل وافر تقديري واحترامي رابط هذا التعليق شارك More sharing options...
محي الدين ابو البشر قام بنشر يوليو 9, 2016 مشاركة قام بنشر يوليو 9, 2016 السلام عليكم يا أخي بارك الله بك وبجهودك رائع رائع رائع أدامك الله وسر خاطرك رابط هذا التعليق شارك More sharing options...
علي حيدر قام بنشر يوليو 9, 2016 مشاركة قام بنشر يوليو 9, 2016 جميل والله بارك اللع فيك رابط هذا التعليق شارك More sharing options...
omar elhosseini قام بنشر يوليو 9, 2016 الكاتب مشاركة قام بنشر يوليو 9, 2016 الاخوة الاعزاء سليم حاصبيا ياسر خليل أبو البراء محي الدين ali haidar بارك الله فيكم الاخوة الاعزاء رابط هذا التعليق شارك More sharing options...
مهند الزيدي قام بنشر يوليو 9, 2016 مشاركة قام بنشر يوليو 9, 2016 شكرا للاح "" عمر الحسيني "" وفقك الله لكل خير ... وكل عام وانت بخير وجميع اعضاء منتدى اوفسنا الرائع.. اذا اردنا ان يكون المجموع ليس للعمود E فقط ولكن مثلا للعمود من B الى E أو أعمدة متفرقة حسب الحاجة .. وشكرا لكل أخي العزيز مرة أخرى 1 رابط هذا التعليق شارك More sharing options...
omar elhosseini قام بنشر يوليو 10, 2016 الكاتب مشاركة قام بنشر يوليو 10, 2016 الاخ مهند الزيدي تم التعديل حسب طلبك الان يمكنك ان يكون المجموع ليس للعمود E فقط ولكن مثلا للعمود من B الى E أو أعمدة متفرقة حسب الحاجة ويجب تعديل المعطيان داخل الكود '========================================= First_Cel = "A1" ' عنوان اول خلية في جدول البيانات Count_Row_In_Page = 10 ' عدد الصفوف في كل صفحة Arr_Col_Total = Array(12, 5, 3) ' ارقام اعمدة المجموع بالنسبة الي الجدول وليس الأكسل '========================================= تم تعديل بعض الاخطاء في النسخة الاولي فقط كانت لا تعمل اذا كان الجدول لا بيدأ من اول عمود ادراج مجموع كل صفحة & المجموع الكلي_2.rar 3 رابط هذا التعليق شارك More sharing options...
ياسر خليل أبو البراء قام بنشر يوليو 10, 2016 مشاركة قام بنشر يوليو 10, 2016 رائع أخي الغالي أبو تامر لا حرمنا الله من إبداعاتك ... إنك بحق متميز رابط هذا التعليق شارك More sharing options...
saad abed قام بنشر يوليو 10, 2016 مشاركة قام بنشر يوليو 10, 2016 اخى عمر ابداعاتك متعدده ررررررررررررررررررررائئئئئئئئئئئئع جزاك الله خيرا وفقكم الله رابط هذا التعليق شارك More sharing options...
omar elhosseini قام بنشر يوليو 11, 2016 الكاتب مشاركة قام بنشر يوليو 11, 2016 العزيز ياسر خليل أبو البراء شكرا لك اخي الاخ سعد عابد شكرا لك اخي اضافة بسيطة الي الملف لتسهيل تعديل مدخلات الجدول ادراج مجموع كل صفحة & المجموع الكلي_3.rar 1 رابط هذا التعليق شارك More sharing options...
مهند الزيدي قام بنشر يوليو 12, 2016 مشاركة قام بنشر يوليو 12, 2016 شكرا لك أخي العزيز " عمر الحسيني " وفقك الله لكل خير وجعله في ميزان حسناتك رابط هذا التعليق شارك More sharing options...
جلال الجمال_ابو أدهم قام بنشر يوليو 13, 2016 مشاركة قام بنشر يوليو 13, 2016 عمر الحسيني اخى الفاضل ما شاء الله عليك رابط هذا التعليق شارك More sharing options...
عبدالله المجرب قام بنشر سبتمبر 16, 2016 مشاركة قام بنشر سبتمبر 16, 2016 بصراحة كود قمة في الاتقان والتميز سلمت يمينك استاذ عمر الحسيني وعوداً حميداً ومميزا كالعادة رابط هذا التعليق شارك More sharing options...
omar elhosseini قام بنشر سبتمبر 16, 2016 الكاتب مشاركة قام بنشر سبتمبر 16, 2016 الاخ القدير عبدالله المجرب شكرا لك اخي العزيز رابط هذا التعليق شارك More sharing options...
مختار حسين محمود قام بنشر سبتمبر 16, 2016 مشاركة قام بنشر سبتمبر 16, 2016 أستاذ عمر السلام عليكم كود بل هديه رائعة من أستاذ أروع كم أحب مثل هذه الأكواد ؟! تحياتى رابط هذا التعليق شارك More sharing options...
محي الدين ابو البشر قام بنشر سبتمبر 16, 2016 مشاركة قام بنشر سبتمبر 16, 2016 السلام عليكم بارك الله بك وبجهودك و أفكارك النيرة فعلا جميل جداً جزاك الله كل خير رابط هذا التعليق شارك More sharing options...
الردود الموصى بها
Join the conversation
You can post now and register later. If you have an account, sign in now to post with your account.