omar elhosseini

الاخ مهند الزيدي تم التعديل حسب طلبك الان يمكنك ان يكون المجموع ليس للعمود E فقط ولكن مثلا للعمود من B الى E أو أعمدة متفرقة حسب الحاجة ويجب تعديل المعطيان داخل الكود '========================================= First_Cel = "A1" ' عنوان اول خلية في جدول البيانات Count_Row_In_Page = 10 ' عدد الصفوف في كل صفحة Arr_Col_Total = Array(12, 5, 3) ' ارقام اعمدة المجموع بالنسبة الي الجدول وليس الأكسل '========================================= تم تعديل بعض الاخطاء في النسخة الاولي فقط كانت لا تعمل اذا كان الجدول لا بيدأ من اول عمود ادراج مجموع كل صفحة & المجموع الكلي_2.rar

الاخوة الاعزاء سليم حاصبيا ياسر خليل أبو البراء محي الدين ali haidar بارك الله فيكم الاخوة الاعزاء

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

السلام عليكم ورحمة الله وبركاتة موضوعنا اليوم اردت ان تكون صيغتة صيغة عامة تخدم الكثير من موضوعات جداول البيانات وهو ادراج مجموع كل صفحة وايضا المجموع الكلي وكنت قد قدمت هذا الموضوع منذ سنوات وقد اعادت هذة الذكري الي ذهني احدي المشاركات منذ ايام قليلة فبحثت عن الموضوع ولكني لم اجده ثم بحثت في المنتديات الاجنبية لعلي اجد كود لهذا الموضوع فلم اجد الا كود واحد فقط يغطى هذا الموضوع وهو للمبرمج 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_6.rar

الاخ عبداللطيف2016 طبعا بعد تصحيح الكود و استبدال Sheets ("Data") ب ActiveSheet في كامل الكود ربما يكون هذا هو الحل اتبع الصور وشاهد المرفق ربما يعالج المشكلة Omar_1.rar

الاخ Mostafa Ismail اطلع علي هذا الرابط طريقة حساب المنصرف والرصيد بسياسة مايرد اولا يصرف اولا

الاخ al.djaballah الاخ ابو عبدالبارى الاخ حسن محمدسليم عبدالحميد انطرا المرفقات ربما يكون هذا هو المطلوب Omar_1.rar

لم افهم طلبك الملف في حالة كون الخلية K15 خالية تحتوى نتيجة البحث على كل القيم التى تقع بين التاريخين فى كل أوراق العمل اما اذا كنت تقصد الخطأ الذي يحدث عندما تكون احد اوراق البحث لا تحتوي علي بيانات فقد تم علاج ذلك اما اذا كان طلبك خلاف ذلك ارجو التوضيح انظر المرفقات SOP GIZA INDEX.rar

شاهد المرفق Omar_1.rar

الاخ nabilbibo الكود عبارة عن 3 دورات منفصلين ل For ... Next الدورة الاولي تقوم بالتسجيل في مصفوفة علي ارقام الاسطر التي تحتوي علي مدي التواريخ المحددة في مدي الدرجات الدورة الثانية تقوم بنسخ الاسطر التي تم تحديد ارقامها في المصفوفة الي ورقة التقرير الدورة الثالتة هي دورة مزدوجة تعمل علي ورقة التقرير بأن تبحث في اعمدة الدرجات علي العمود الذي لا يحتوي علي مدي التواريخ المحددة ويقوم يحذفة فيتبقي في ورقة التقرير اعمدة الدرجات التي تحتوي علي مدي التواريخ المحددة فقط

الاخ على نور هذه الظريقة متعبة وعقيمة فعند تعديل اسم او تغير الاسماء لابد من حذف النطاقات السابقة وانشاء نطاقات جديدة استخدم هذا الاسلوب بالمرفقات الصور تسمي برقم مسلسل الاسم ( Picture 2 - Picture 1 ) هكذا ويمكنك تغير او تعديل الاسماء كما تشاء Omar_1.rar

تحت امرك اخي صلاح الصغير

انظر المرفقات Omar_2.rar

الاخ صلاح الصغير حمل Office Web Components من الرابط الموجود بالمرفقات_1 النسخة العربية وقم بتركيبها ثم اعد الخطوات من 1 الي 4

قم بإضافة أوراق عمل أخرى كما تشاء الشرط الوحيد لها ان تحتوي الخلية ( A1 ) علي العباره ( # File ) انظر المرفقات Omar_4.rar

الاخ nabilbibo شاهد المرفق Omar_1.rar

اطمع كما تشاء اخي نحن نأمل زيادة الطمع لننال الثواب والدعاء انظر المرفق تم القاء قائمة التواريخ بالنسبة لأضافة اوراق عمل جديدة هل اسماء اوراق العمل نمطية كما في المثال ( File 1 -File 2 ....... ) ام ماذا بالنسبة للبحث في كل الصفحات هل البحث في كل الاعمده Omar_3.rar

نسخة منقحه Omar_2.rar

الاخ aladdien انظر المرفقات لعل وعسي يكون المطلوب Omar_1.rar

الا خ ياسر خليل أبو البراء عودا حميدا كل سنة وانت طيب اعاد الله رمضان عليك وعلي امة الاسلام باليمن والبركات نورت المنتدي

الاخ وائل عزالدين شاهد المرفق Omar_1.rar

الاخ سليم حاصبيا احسنت اخي سليم حاصبيا