كود تجميع نطاق معين بين تاريخين من جميع صفحات الملف

[abouelhassan]

اخواتى الاساتذة الافاضل 

اريد مساعدة بدالة sumif لتجميع عدد 29 شيت بدلالة التاريخ من الى النطاق من E5 :i600000 في كل شييت
مع الشكر

 

New_Microsoft_Excel_Worksheet.xls

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

ليس من المعقول تتبع ماكرو ما على 30 صفحة

رجاء ارفع ملفاً بسيطاُ  (3 شيتات لا أكثر) لان الماكرو الذي ينفذ على شيت واحده يمكنه ان ينفذ على الوف الشيتات

مع اخذ بعين الاعتبار ادراج بيانات و ليس جداول فارغة (مع الحفاظ على الجداول بأن لا تحتوي على خلايا مدمحة ولا تتداخل معها خلايا لا علاقة للجداول بها)

[abouelhassan]

حفظك الله استاذنا

انا اسف 

تم عمل اللازم مع الشكر

New Microsoft Excel Worksheet.rar

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

جرب هذا الكود

Option Explicit

Sub Get_sum()
  Dim Main As Worksheet
  Dim Sh As Worksheet
  Dim Start_Date As Date, Final_date As Date
  Dim Last_Row%, i%
  Dim AL_Result#
  
Set Main = Sheets("Salim")
Start_Date = Main.Cells(2, 3): Final_date = Main.Cells(2, 4)
 For Each Sh In Sheets
  If Sh.Name <> Main.Name Then
      Last_Row = Sh.Cells(Rows.Count, 1).End(3).Row
       For i = 5 To Last_Row
         If Sh.Cells(i, 1) >= Start_Date And _
          Sh.Cells(i, 1) <= Final_date Then
          AL_Result = AL_Result + _
          Application.Sum(Sh.Cells(i, 1).Offset(, 4).Resize(, 5))
         End If
       Next i
   End If
 Next Sh
 Main.Cells(2, 2) = AL_Result
 Set Main = Nothing: Set Sh = Nothing
  
End Sub

الملف مرفق

 

Total_sum.xlsm

[abouelhassan]

الله الله الله استاذنا رائع

بس لى ان اطمع قليلا بارك الله فيك

فى اخر اليوم اقوك بكتابة  التاريخ والاجمالى فى كل شيت فيتم جمع الاعمدة هل لى بطلب انا يقوم الكود بالجمع كما هو تمام الان الا الصفوف التى بها كلمة الاجمالى مع خالص تقديرى لكرمك

الكثير استاذنا سليم الفاضل ربنا يحفظك اللهم امين يارب

معلش استاذنا انا اسف ولو عايز استسنى صفحة شيت

يعنى طلبين مع الشكر استثناء الصفوف التى بها كلمة الاجمالى

واستثناء صفحة اسمها النقدية مع خالص تقديرى لشخص حضرتك الكريم جداااااا

اخيك باحترام

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

1-لم اجد ورقة اسمها النقدية في الملف

2- كما لم اجد اي صف فيه كلمة اجمالي

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

Option Explicit

Sub Get_Sum_By_Array()
  Dim Main As Worksheet
  Dim Sh As Worksheet
  Dim Start_Date As Date, Final_date As Date
  Dim Last_Row%, i%, m%, AL_Result#
  Dim arr()
  
Set Main = Sheets("Salim")
Start_Date = Main.Cells(2, 3)
Final_date = Main.Cells(2, 4)
 
 For Each Sh In Sheets
       If Sh.Name <> Main.Name Then
         Last_Row = Sh.Cells(Rows.Count, 1).End(3).Row
          For i = 5 To Last_Row
             If Sh.Cells(i, 1) >= Start_Date And _
              Sh.Cells(i, 1) <= Final_date Then
                ReDim Preserve arr(m)
                arr(m) = _
                      Application.Sum(Sh.Cells(i, 1). _
                      Offset(, 4).Resize(, 5))
                m = m + 1
             End If
          Next i
           If m > 0 Then
            Sh.Cells(4, 2) = Application.Sum(arr)
            AL_Result = AL_Result + Application.Sum(arr)
           Else
            Sh.Cells(4, 2) = 0
            AL_Result = AL_Result
           End If
            Erase arr: m = 0
     End If
 Next Sh
 
 Main.Cells(2, 2) = AL_Result
 Set Main = Nothing: Set Sh = Nothing
  
End Sub

الملف من جديد

 

 

Total_sum_New.xlsm

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

بعض التجسينات على الكود (لتحديد الصفوف المطلوبة للجمع حسب التواريخ)

Option Explicit

Sub Get_Sum_By_Array()
  Dim Main As Worksheet
  Dim Sh As Worksheet
  Dim Start_Date As Date, Final_date As Date
  Dim Last_Row%, i%, m%, AL_Result#
  Dim arr()
  
Set Main = Sheets("Salim")
Start_Date = Main.Cells(2, 3)
Final_date = Main.Cells(2, 4)
 
 For Each Sh In Sheets
       If Sh.Name <> Main.Name Then
       Last_Row = Sh.Cells(Rows.Count, 1).End(3).Row
       Sh.Range("A5:I" & Last_Row).Interior.ColorIndex = xlNone
             For i = 5 To Last_Row
             If Sh.Cells(i, 1) >= Start_Date And _
              Sh.Cells(i, 1) <= Final_date Then
              Sh.Cells(i, 1).Resize(, 9) _
              .Interior.ColorIndex = 6
                ReDim Preserve arr(m)
                arr(m) = _
                      Application.Sum(Sh.Cells(i, 1). _
                      Offset(, 4).Resize(, 5))
                m = m + 1
             End If
          Next i
           If m > 0 Then
            Sh.Cells(4, 2) = Application.Sum(arr)
            AL_Result = AL_Result + Application.Sum(arr)
           Else
            Sh.Cells(4, 2) = 0
            AL_Result = AL_Result
           End If
            Erase arr: m = 0
     End If
 Next Sh
 
 Main.Cells(2, 2) = AL_Result
 Set Main = Nothing: Set Sh = Nothing
  
End Sub

الملف من جديد

Total_sum_Super.xlsm

[abouelhassan]

الله يرضى عنك استاذنا الله يبارك فيك يارب ويجازيك كل خير الدنيا وخير الاخرة يارب

اشكرك من كل قلبى

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

مرفق الملف

Total_sum_Super.rar

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

تم النعديل على الماكرو كما تريد

Option Explicit

Sub Get_Sum_By_Array()
  Dim Main As Worksheet
  Dim Sh As Worksheet
  Dim Start_Date As Date, Final_date As Date
  Dim Last_Row%, i%, m%, AL_Result#
  Dim arr()
  Dim Tst$
Set Main = Sheets("Salim")
Start_Date = Main.Cells(2, 3)
Final_date = Main.Cells(2, 4)
Tst = "الاجمالى"

For Each Sh In Sheets
           If Sh.Name = Main.Name Or _
           Sh.Name = "النقدية" Then GoTo Next_SH
           Last_Row = Sh.Cells(Rows.Count, 1).End(3).Row
           Sh.Range("A5:i" & Last_Row).Interior.ColorIndex = xlNone
           
    For i = 5 To Last_Row
      With Sh.Cells(i, 1)
        If .Value >= Start_Date And _
           .Value <= Final_date And _
           .Offset(, 1) <> Tst Then
           .Resize(, 9).Interior.ColorIndex = 6
             ReDim Preserve arr(m)
             arr(m) = _
                   Application.Sum(Sh.Cells(i, 1). _
                   Offset(, 4).Resize(, 5))
             m = m + 1
       End If '.value
    End With
   Next i
  If m > 0 Then
   Sh.Cells(4, 2) = Application.Sum(arr)
   AL_Result = AL_Result + Application.Sum(arr)
  Else
   Sh.Cells(4, 2) = 0
   AL_Result = AL_Result
  End If
   Erase arr: m = 0
Next_SH:
 Next Sh
 
 Main.Cells(2, 2) = AL_Result
 Set Main = Nothing: Set Sh = Nothing
  
End Sub

الملف مرفق

 

Total__Super.xlsm

[abouelhassan]

الله يبارك لك يارب والله مش عارف اشكر حضرتك اد ايه ربنا يحفظك يارب

استاذنا 

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

مع خالص تقديرى واحترامى لشخصك الكريم جدااااا

بارك الله لك وبك اللهم امين

تم عمل اللازم استاذنا وتغير رقم 6 باللون الى 0 وتمام التمام

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

احترامى وتقديرى من القلب

استفسار استاذى واعذرنى لدى فورم كليندر نتيجة هل يمكن واضعه لاختيار التاريخ منه بدل الكتابة

هل سيتعارض مع الكود الاصلى مع خالص تقديرى لشخصكم الكريم

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

اللون الاصفر يشير إلى التواريخ التي اخترتها (بين تاريخين)

بالنسبة للكليندر يجب وضع 2 منها كل واحد برتبط بخلية (C2 & D2)

او ادراج قوائم منسدلة في الخليتين

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

التواريخ مرتبة تصاعدياً في القائمة الاولى    وتنازلياً في الثانية

Option Explicit

Sub Get_data_val()


  Dim Main As Worksheet
  Dim Sh As Worksheet
  Dim CoL1 As Object
  Dim CoL2 As Object
  Dim i%, Last_Row%, m%

  
Set Main = Sheets("Salim")
Set CoL1 = CreateObject("System.Collections.Arraylist")
For Each Sh In Sheets
If Sh.Name <> Main.Name Then
  i = 5
  Do Until Sh.Range("A" & i) = vbNullString
   With Sh.Range("A" & i)
   If IsDate(.Value) And Not CoL1.contains(.Value) Then
    CoL1.Add (.Value)
    End If
   End With
   i = i + 1
   Loop
End If
Next
Set CoL2 = CoL1.Clone
CoL1.Sort: CoL2.Sort
CoL1.Reverse
With Main.Range("D2").Validation
 .Delete
 .Add 3, Formula1:=Join(CoL1.toarray, ",")
End With

With Main.Range("C2").Validation
 .Delete
 .Add 3, Formula1:=Join(CoL2.toarray, ",")
 End With
Set Main = Nothing: Set Main = Nothing
Set CoL1 = Nothing: Set CoL2 = Nothing
End Sub

 

Total_sum_With_DV.xlsm

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

لا حاجة للكليندر بوجود القوائم المنسدلة (فقط عند نعديل او اضافة او حذف اي بيانات او تواريخ اضغط على الزر Get data validation)

كي يعمل الكود جيداً بدون مشاكل لا يجب ان يكون خلايا فارغة في كل الجداول (العامود الاول ابتداء من الصف الخامس من كل ورقة  ما عدا Salim)

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

في الكود الحرف (ِA)  يدل على العامود A

اذا كنت تريد تغيير العامود استبدل  A   باسم آخر الذي تريده  احياناً قد تجد حرف (a)  لا مشكلة بذلك

[abouelhassan]

أستاذى 

الكود جميل جدااا ويعمل معى تمام

عايز اعمل منه 3 الكود تمام مثله تمام

التغير .فقط بدل ما الجمع بيكون فى النطاق eالى i

اريد الكود يجمع العامود eفقط

وكود اخر يجمع fفقط وهكذا

يعنى الكود يعمل تمام جدا

اريد ان اعمل اربع الكود منه بنفس الكود فقط التغير أنه يجمع عامود واحد بدلالة التاريخ

اشكرك استاذي الفاضل بارك الله فيك اخي الكريم

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

Application.Sum(Sh.Cells(i, 1). _ Offset(, 4).Resize(, 5)

في هذا السطر الرقم 5 في ((Resize(, 5) هو عدد الأعمدة التي تريد جمعها ابتداء من العامود الذي مسجل في (Offset(, 4  وتضيف عليه 1                         (4+1)=5  (العامود E رقمه 5)

مثلا اذا كنت تريد جمع عامود واحد تكتب   (Resize(, 1   العامود  فقط E

اذا كنت تريد جمع عامودين   تكتب (Resize(, 2  العامودين  E و  F

 

[abouelhassan]

الله االله الله تم تم

ربنا يحفظك يارب الله يكرمك استاذى يارب ويحفظك يارب

كل عتم وانت واسرتك بكل خير الدنيا يارب

حبيبى والله

احترامى اخى الغالى واستاذى الله يكرمك يارب دائما

[abouelhassan]

السلام عليكم استاذى سليم حاصبيا

انا اسف والله سامحنى بالله عليك

احتاج للكود يتم كما هو على صفحة النقدية فقط كما هو 

لم اعرف تطبيقه للاسف استاذى

مع خالص شكرى واعتذارى لشخصك الكريم

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

تم معالجة الأمر

Total__Super_1.xlsm

[abouelhassan]

الله الله الله

كل الاحترام والشكر من قلبى لحضرتك استاذى الجليل

سليم حاصبيا 

ربنا يحفظك ويبارك لك ويكرمك اللهم امين من قلبى والله

احترامى لشخصك الكريم جداااااااااااااااا