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

[Ahmed Nofal]

السلام عليكم اخواني الاعزاء

محتاج تجميع كل صفحة على حدة في الطباعة في الشيت المرفق

ولكم جزيل الشكر

مرتبات.xlsx

[أحمد يوسف]

وعليكم السلام-تفضل

1مرتبات.xlsx

[سليم حاصبيا]

للمرة المائة بعد الالف استقلالية الجدول و عدم ادراج خلايا مدمجة في داخله

تم ادراج صفين فارغين تماماً( 7 و  8 ) و تم اخفائهما لعدم الكتاية فيهما عن طريق الخطأ مما يؤثر سلباً على الكود

الكود

Option Explicit
Sub Myfilter()
Dim sh As Worksheet
Dim Ar_Sh(), AR_comp(), I%
Dim RG_Filter As Range, Ro%, K%
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
Set sh = Sheets("2021-3")
Set RG_Filter = sh.Range("B8").CurrentRegion
If sh.AutoFilterMode Then RG_Filter.AutoFilter
Ro = RG_Filter.Rows.Count
AR_comp = Array("شركة", "بنك مصر", "معاش")
Ar_Sh = Array("Company", "Salery", "Bank")
For I = LBound(Ar_Sh) To UBound(Ar_Sh)
    Sheets(Ar_Sh(I)).Range("A10:R1000").Clear
    RG_Filter.AutoFilter 4, AR_comp(I)
     RG_Filter.Cells(2, 1).Resize(Ro - 1, 18) _
    .SpecialCells(12).Copy
    
    With Sheets(Ar_Sh(I)).Range("A10")
        .PasteSpecial (8)
        .PasteSpecial (12)
         K = .CurrentRegion.Rows.Count
        .Offset(K) = "Sum"
        .Offset(K, 6).Resize(, 12).Formula = _
         "=SUM(G10:G" & K + 9 & ")"
         .Offset(K, 6).Resize(, 12).Value = _
         .Offset(K, 6).Resize(, 12).Value
         .Offset(K).Resize(, 18).Interior.ColorIndex = 35
            With .Resize(K + 1, 18)
              .Borders.LineStyle = 1
              .Font.Size = 14
              .InsertIndent 1
            End With
          .Offset(K).Resize(, 6).HorizontalAlignment = 7
    End With
Next
If sh.AutoFilterMode Then RG_Filter.AutoFilter

With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
.CutCopyMode = False
End With

sh.Activate
Range("g9").Select
End Sub

الملف مرفق

Nafal.xlsm

[Ahmed Nofal]

اشكرك على تعبك واهتمامك أستاذ أحمد يوسف

لكنى اريد التجميع في الطباعه فقط و  ليس في حقل العمل

[سليم حاصبيا]

هذه بقى لم افهمها

لكنى اريد التجميع في الطباعه فقط و  ليس في حقل العمل

[Ahmed Nofal]

حضرتك محتاج التجميع يظهر في نهاية كل صفحة في الطباعة فقط مثل الصورة المرفقة , اما في حقل العمل لايظهر غير التجميع النهائي فقط كما في ملف اكسل المرفق

مرتبات.xlsx

[سليم حاصبيا]

في صفحة مستقلة اكتب النتائج التي تتوقعها

(و لا ضرورة لادراج اكثر من 200 ضف ) 15 الى 20 صف تكفي

[Ahmed Nofal]

بحتاج المجموعة كاملة لاني لو جزئتهم على الصفحات لا استطيع الاستفادة من عامل التصفية والتجميع النهائي هيطلع مش مظبوط 

[سليم حاصبيا]

ربما تحناح الى هذا الملف (النتيجة في الصفحة ALL)

Sub Filter_All()
Dim sh As Worksheet
Dim A As Worksheet
Dim AR_comp()
Dim Ro%, K%, x%, t%, I%
    With Application
    .ScreenUpdating = False
    .Calculation = xlCalculationManual
    End With
Set sh = Sheets("2021-3")
Set A = Sheets("ALL")
Set RG_Filter = sh.Range("B8").CurrentRegion
If sh.AutoFilterMode Then RG_Filter.AutoFilter
A.Range("A10:R1000").Clear
Ro = RG_Filter.Rows.Count
AR_comp = Array("شركة", "بنك مصر", "معاش")

 t = 10
For I = LBound(AR_comp) To UBound(AR_comp)
     RG_Filter.AutoFilter 4, AR_comp(I)
     RG_Filter.Cells(2, 1).Resize(Ro - 1, 18) _
    .SpecialCells(12).Copy
    With A
        .Range("A" & t).PasteSpecial (8)
        .Range("A" & t).PasteSpecial (12)
           x = _
        .Cells(Rows.Count, 1).End(3).Row + 1
        .Cells(x, 1) = "Sum"
        .Cells(x, "G").Resize(, 12).Formula = _
           "=SUM(G" & t & ":G" & x - 1 & ")"
        .Cells(x, 1).Resize(, 6).HorizontalAlignment = 7
        .Cells(x, 1).Resize(, 18).Interior.ColorIndex = 35
     t = x + 1
   End With
Next I
 If t = 10 Then GoTo End_me
  
   With A.Cells(t, 1)
    .Value = "TOTAL SUM :"
    .Resize(, 6).HorizontalAlignment = 7
    .Resize(, 18).Interior.ColorIndex = 40
    .Offset(, 6).Resize(, 12).Formula = _
      "=SUM(G10:G" & t - 1 & ")/2"
  End With

   With A.Range("A10").CurrentRegion
    .Borders.LineStyle = 1
    .Font.Size = 14
    .Font.Bold = True
    .Value = .Value
   End With
End_me:
 If sh.AutoFilterMode Then RG_Filter.AutoFilter
With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
.CutCopyMode = False
End With

A.Activate
Range("A10").Select
End Sub

الملف مرفق

Nafal_1.xlsm