اذهب الي المحتوي
أوفيسنا
بحث مخصص من جوجل فى أوفيسنا
Custom Search

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


الردود الموصى بها

السلام عليكم

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

في أول الكود تحط الشروط المراده
* بداية البيانات بدون رؤس الاعمدة
* الاعمدة المراد عمل عليها جمع
بالامكان تحديد الاعمده اما بشكل فردي وهو "$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

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

  • Like 4
رابط هذا التعليق
شارك

السلام عليكم

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

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

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

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

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

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

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

رابط هذا التعليق
شارك

السلام عليكم

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

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

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

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

الاخ الفاضل astika

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

Kh_Sum_Pages.rar

تم تعديل بواسطه عباد
  • Like 2
رابط هذا التعليق
شارك

السلام عليكم

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

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

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

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

أرجو التوضيح

تحياتي

رابط هذا التعليق
شارك

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

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

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

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

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

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

مجاميع الصفحات حسب عناوين الصفوف في العمود 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

تم تعديل بواسطه عباد
  • Like 2
رابط هذا التعليق
شارك

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

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

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

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

formula in the end of the page.rar

  • Like 1
رابط هذا التعليق
شارك

  • 10 months later...

من فضلك سجل دخول لتتمكن من التعليق

ستتمكن من اضافه تعليقات بعد التسجيل



سجل دخولك الان
×
×
  • اضف...

Important Information