البحث في الموقع

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