كود انشاء صف مجموع في اخر فواصل الصفحات

[الـعيدروس]

السلام عليكم

هذا كود من أعمال الأستاذ الكبير عبدالله باقشير حفظه الله ورعاه
أحببت أن اطرحه في موضوع كي يستفيد منه الجميع

في أول الكود تحط الشروط المراده
* بداية البيانات بدون رؤس الاعمدة
* الاعمدة المراد عمل عليها جمع
بالامكان تحديد الاعمده اما بشكل فردي وهو "$A$1,$C$1,$F$1"
أو بشكل مدى من الى هكذا "$A$1:$G$1"
أو بشكل مدى متقطع هكذا "$A$1,$C$1,$E$1:$H$1,$i$1:$K$1"

********************************************************************
الكود ينشاء صف وبه الجمع وبعد الانتهاء من وضع معاينة الطباعه يحذف الصف

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

الكود يوضع في مودويل

'****************************************
' بداية البيانات بدون رؤس الأعمدة
Private Const Row_Star As Integer = 2
'****************************************
'الاعمدة المراد جمع قيمها في نهاية فواصل الصفحات
Private Const C_N As String = "$A$1,$C$1,$D$1:$F$1"
Sub Ali_Sum_Page()
Dim Ar() As Integer
Dim Rng As Range, Cc As Range
Dim C As Range, Cr As Range
Dim iCont As Integer
Dim i As Integer, ii As Integer
Dim r1 As Integer, r2 As Integer
Dim Cv As Integer, L_C As Integer
'''''''''''''''''''
For Each Cc In Range(C_N)
    L_C = Cc.Column
Next
With Cells.Worksheet
With .PageSetup
	 .PrintTitleRows = "$1:$1"
	 .PrintTitleColumns = ""
End With
	 .ResetAllPageBreaks
	 .Range("A65536").Select
	 .Cells(Row_Star, "A").Select
	 iCont = .HPageBreaks.Count
	 If iCont = 0 Then Exit Sub
	 '''''''''''''''''''''''
	 ReDim Ar(1 To iCont)
	  For i = 1 To .HPageBreaks.Count
		  ii = .HPageBreaks(i).Location.row
		  Ar(i) = ii
	  Next
	  '''''''''''''''''''''''
	  r1 = Row_Star
	  For i = 1 To iCont
		  ii = Ar(i) - 1
	  With .Range("A" & ii).Resize(1, L_C)
		    .EntireRow.Insert
		    With .Offset(-1, 0)
			    L_r = Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).row
			    If Rng Is Nothing Then Set Rng = .Cells Else Set Rng = Union(Rng, .Cells)
			    r2 = ii - 1
			  For Each C In Range(C_N)
				 Cv = C.Column
				 .Cells(1, Cv) = WorksheetFunction.Sum(Range(Cells(r1, Cv), Cells(r2, Cv)))
			  Next
			    r1 = r2 + 2
			 End With
	  End With
	    Next
	    For Each Cr In Range(C_N)
	    Cv = Cr.Column
	    With .Cells(L_r, Cv)
			 .Value = WorksheetFunction.Sum(Range(Cells(r1, Cv), Cells(L_r - 1, Cv)))
			 .Interior.ColorIndex = 6
	    End With
	    Next
End With
''''''''''''''''''''''
If Not Rng Is Nothing Then
	    With Rng
		  .Interior.ColorIndex = 6
		  .Worksheet.PrintPreview
		   Range("A" & L_r).EntireRow.Delete
		  .EntireRow.Delete
	    End With
End If
'''''''''''''''''''''''
Erase Ar
Set Rng = Nothing: Set Cc = Nothing
Set Cr = Nothing: Set C = Nothing
End Sub

والسلام عليكم

[إبراهيم ابوليله]

اخى عباد

مشاء الله كود قد يحاتجه

كل من يستخدم الاكسيل

بارك الله فيك

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

السلام عليكم

اخي الحبيب عباد ---------------حفظك الله

ما هذا التواضع اخي الكريم

انا قمت بتعديل صغير لا يذكر على الكود

اما اساس الكود وفكرته هي من روائعك انت

فلا تنسبها لي خجلا مني فهي حق من حقوقك

جزاك الله خيرا وبارك فيك

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

[أستيكا]

ممكن من الاخوة العباقرة اعطاء مثال بشيت اكسيل توضيحى

[الـعيدروس]

السلام عليكم

الاخ الفاضل أبو ليله شكر لك على مورك الكريم

الأستاذ العبقري والخلوق جدا عبدالله باقشير حفظك الله

بالعكس استاذ عبدالله تعديلك من نصيب الأسد

جزاك الله خير وبارك فيك وأطال الله بعمرك

الاخ الفاضل astika

إطلع على المرفقات

Kh_Sum_Pages.rar

تم تعديل ديسمبر 11, 2012 بواسطه عباد

[ايهاب سعيد]

اخي الفاضل هذا الكود رائع

هل يمكن ان تصنع كود يعطي ملخص الكشوف

بمعني الكشف الاول مجموع الخانات السابقة

الكشف الثاني مجمو الخانات

الثالث وهكذا

[الـعيدروس]

السلام عليكم

الاخ ايهاب سعيد

ماذا تقصد ملخص الكشوف

وماهو الكشف الأول هل تعني صفحة رقم 1 في معاينة الطباعه ؟

ومجموع الخانات السابقة هل تقصد عدد صفوف الصفحه السابقة بمعنى الصفوف الممتلئه

أرجو التوضيح

تحياتي

[أبو حنــــين]

جزاك الله خيرا أخي الحبيب أبو نصار على هذا العمل الممتاز

و الشكر موصول لأخينا الحبيب عبد الله

تم تعديل ديسمبر 12, 2012 بواسطه دغيدى

[ايهاب سعيد]

اخي الفاضل عباد اشكرك علي الاهتمام

بخصوص قصدي هو ملخص باجماليات الصفحات

فمثلا لو ان يكون هناك ملخص بمجاميع الصفحات حسب عناوين الصفوف

[ايهاب سعيد]

up

[الـعيدروس]

الاخ الاستاذ الحبيب أبو حنين

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

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

الاخ الفاضل ايهاب سعيد

ماذ تقصد بعنواين الصفوف

حسب مافهمت جرب التعديل التالي

مجاميع الصفحات حسب عناوين الصفوف في العمود A التي باللون الاحمر في معاينة الطباعه

'****************************************

' بداية البيانات بدون رؤس الأعمدة

Private Const Row_Star As Integer = 2

'****************************************

'الاعمدة المراد جمع قيمها في نهاية فواصل الصفحات

Private Const C_N As String = "$B$1,$C$1,$D$1:$F$1"

Sub Ali_Sum_Page()

Dim Ar() As Integer

Dim Rng As Range, Cc As Range

Dim C As Range, Cr As Range

Dim iCont As Integer

Dim Arc As Variant

Dim P_c

Dim i As Integer, ii As Integer

Dim r1 As Integer, r2 As Integer

Dim Cv As Integer, L_C As Integer

'''''''''''''''''''

On Error Resume Next

Arc = Range(C_N).Address(0, 0)

P_c = Range(Mid(Arc, 1, 2)).Column

For Each Cc In Range(C_N)

L_C = Cc.Column

Next

With Cells.Worksheet

With .PageSetup

	 .PrintTitleRows = "$1:$1"

	 .PrintTitleColumns = ""

End With

	 .ResetAllPageBreaks

	 .Range("A65536").Select

	 .Cells(Row_Star, "A").Select

	 iCont = .HPageBreaks.Count

	 If iCont = 0 Then Exit Sub

	 '''''''''''''''''''''''

	 ReDim Ar(1 To iCont)

	 For i = 1 To .HPageBreaks.Count

		 ii = .HPageBreaks(i).Location.row

		 Ar(i) = ii

	 Next

	 '''''''''''''''''''''''

	 r1 = Row_Star

	 For i = 1 To iCont

		 ii = Ar(i) - 1

	 With .Cells(ii, P_c).Resize(1, L_C)

		 .EntireRow.Insert

		 With .Offset(-1, 0)

			 L_r = Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).row

			 If Rng Is Nothing Then Set Rng = .Cells Else Set Rng = Union(Rng, .Cells)

			 r2 = ii - 1

			 For Each C In Range(C_N)

				 Cv = C.Column

				 .Cells(1, Cv) = WorksheetFunction.Sum(Range(Cells(r1, Cv), Cells(r2, Cv)))

			 With Cells(.row, 1)

				 .Value = WorksheetFunction.CountA(Range(Cells(r1, Cv), Cells(r2, Cv)))

				 .Interior.Color = RGB(255, 0, 0)

			 End With

			 Next

			 r1 = r2 + 2

			 End With

	 End With

	 Next

	 For Each Cr In Range(C_N)

	 Cv = Cr.Column

	 With .Cells(L_r, Cv)

			 .Value = WorksheetFunction.Sum(Range(Cells(r1, Cv), Cells(L_r - 1, Cv)))

			 With Cells(L_r, 1)

				 .Value = WorksheetFunction.CountA(Range(Cells(r1, Cv), Cells(L_r - 1, Cv)))

				 .Interior.Color = RGB(255, 0, 0)

		 End With

			 .Interior.ColorIndex = 6

	 End With

	 Next

End With

''''''''''''''''''''''

If Not Rng Is Nothing Then

	 With Rng

		 .Interior.ColorIndex = 6

		 .Worksheet.PrintPreview

		 Range("A" & L_r).EntireRow.Delete

		 .EntireRow.Delete

	 End With

End If

'''''''''''''''''''''''

Erase Ar

Set Rng = Nothing: Set Cc = Nothing

Set Cr = Nothing: Set C = Nothing

End Sub

Kh_Sum_Pages_A.rar

تم تعديل ديسمبر 13, 2012 بواسطه عباد

[محمد يحياوي]

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

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

فاحببت ان اثري الموضوع لزيادة الفائدة ...

شكري و احترامي...

formula in the end of the page.rar

[الـعيدروس]

الاستاذ الحبيب محمد يحياوي

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

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

[ايهاب سعيد]

اخي الفاضل اردت تطبيق كوك السابق علي الملف ولكن اعطي نتائج خاطئة مرفق لسياتكم الملف

[ايهاب سعيد]

اخي الفاضل اردت تطبيق كوك السابق علي الملف ولكن اعطي نتائج خاطئة مرفق لسياتكم الملف

كود جمع.rar

[أبو سجده]

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