نتيجة اجمالي بيانات من صفحات في صفحة حسب الفترة

[حسين مامون]

اخواني اساتذة المنتدى الرائع

السلام عليكم ورحمة الله

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

ولما لاهمية الموضوع عندي فتقبلوا اعتذاري لاعادة وضعه مرة اخرى ,

اولا اريد تطبيقه على ملف عملي الذي يحتوي على اكثر من 250شيت,

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

======================

طلبي هو:

عندي في الملف  المرفق كما قلت اكثر من 250شيت مرقم في كل شيت نفس الجدول ولكن يكون الاختلاف في تاريخ الدفع من شيت لاخر

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

كما في النمودج

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

تجميع بيانات2.rar

[ياسر خليل أبو البراء]

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

جرب الكود التالي

Sub Test()
    Dim ws          As Worksheet
    Dim sh          As Worksheet
    Dim rngDates    As Range
    Dim rngTotal    As Range

    Application.ScreenUpdating = False
        Set sh = Feuil1
        For Each ws In ThisWorkbook.Worksheets
            If ws.Name <> sh.Name Then
                If ws.Range("B9").Value <> "" Then
                    ws.Range("B9:E" & ws.Cells(Rows.Count, 2).End(xlUp).Row).Copy
                    Feuil1.Cells(Rows.Count, 9).End(xlUp).Offset(1).PasteSpecial xlPasteValues
                End If
            End If
        Next ws
        Application.CutCopyMode = False
    
        If sh.Range("I2").Value = "" Then Exit Sub
        Set rngDates = sh.Range("I2:I" & sh.Range("I2").CurrentRegion.Rows.Count + 1)
        Set rngTotal = sh.Range("J2:J" & sh.Range("J2").CurrentRegion.Rows.Count + 1)
    
        With sh.Range("E4:E" & sh.Cells(Rows.Count, 4).End(xlUp).Row)
            .Formula = "=SUMPRODUCT(--(MONTH(" & rngDates.Address & ")=MONTH(D4))*(YEAR(" & rngDates.Address & ")=YEAR(D4)),--(" & rngTotal.Address & "))"
            .Value = .Value
        End With
        sh.Columns("I:J").ClearContents
        Application.Goto sh.Range("A1")
    Application.ScreenUpdating = True
End Sub

 

[حسين مامون]

السلام عليكم 

استاذ خليل ابو البراء

الف شكر وتقدير  

ساجرب لما اكون في المكتب  الان اجيب من الموبايل

تحياتي

[ابراهيم الحداد]

اخى الكريم الاستاذ  حسين

السلام عليكم ورحمة الله

اعتقد اننى قد عملت على هذا الملف من حوالى ثلاثة اسابيع وظننت انى قد وفقت فى الحل

ولم ادخل الى الموضوع مرة اخرى فأعتذر اننى لم ارى ردودك  اواستفساراتك مرة اخرى

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

وليأذن لى استاذى معلمى الاستاذ ياسر بعرض هذا الكود حيث ان نتائجه تطابق نفس المخرجات الواردة بالملف

عدا الصف رقم 18 فالخطأ من عند الاستاذ حسين وليس من الكود

ودمتم بالف خير

Sub Collect()
Dim sh As Worksheet, ws As Worksheet
Dim x As Long
Set ws = Sheets("الرئيسية")
ws.Range("E4:E50").ClearContents
For R = 4 To ws.Range("D" & Rows.Count).End(xlUp).Row
Z = 0
For Each sh In Worksheets
If sh.Name <> "الرئيسية" And sh.Name <> "namodaj" And sh.Name <> "طباعة" Then
For x = 9 To sh.Range("B" & Rows.Count).End(xlUp).Row
If Year(sh.Cells(x, 2)) = Year(ws.Cells(R, 4)) And _
   Month(sh.Cells(x, 2)) = Month(ws.Cells(R, 4)) Then
 Z = Z + sh.Cells(x, 3).Value
 ws.Cells(R, 5) = Z
End If
Next
End If
Next
Next
End Sub

 

[حسين مامون]

اخي زيزو اسكرك على كل شيء

ارجو ان تقبل اعتذاري 

انشاء الله لما اكون في المكتب ساجرب وارد 

تحياتي

[حسين مامون]

السلام عليكم ورحمة الله

استاذنا ياسر خليل أبو البراء

استاذنا زيزو العجوز

في يوم الجمعة هذا  اسأل الله ان يجزيكما  ويحفظكما من كل شر  

عملين ممتازين في المستوى المطلوب

الكودين يعطيان نفس النتيجة  وهي ايجابية ومرضية وسأنقله الى ملف عملي ان شاء الله

الف الف شكر للاستاذين المحترمين

[حسين مامون]

استاذي المحترم

خليل ابو البراء

 السلام عليكم ورحمة الله

 بعذ اذنك ممكن اضافة تعديل للكود ليعطي نتيجة  اجمالي عمود F و عود G   حسب الفترة من كل صفحة مرقمة باستثناء **NAMODAJ و طباعة والرئيسية

Nouveau Archive WinRAR.rar

[ياسر خليل أبو البراء]

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

إذا أردت عمل استثناء لأوراق عمل معينة قم بإضافة سطر بعد سطر الحلقة التكرارية شبيه بما قدمه أخونا زيزو العجوز

If sh.Name <> "الرئيسية" And sh.Name <> "namodaj" And sh.Name <> "طباعة" Then

ولا تنسى الجملة End IF قبل نهاية الحلقة التكرارية

[حسين مامون]

شكرا استاذ 

 وماذا عن اجمالي العمودين الاضافيين هل من طريقة

تحياتي

[ياسر خليل أبو البراء]

جرب الكود بالشكل التالي

Option Explicit

Sub Test()
    Dim ws          As Worksheet
    Dim sh          As Worksheet
    Dim rngDates    As Range
    Dim rngTotal    As Range
    Dim rngFine     As Range

    Application.ScreenUpdating = False
        Set sh = Feuil1
        For Each ws In ThisWorkbook.Worksheets
            If ws.Name <> "الرئيسية" And ws.Name <> "namodaj" And ws.Name <> "طباعة" Then
                If ws.Name <> sh.Name Then
                    If ws.Range("B9").Value <> "" Then
                        ws.Range("B9:F" & ws.Cells(Rows.Count, 2).End(xlUp).Row).Copy
                        Feuil1.Cells(Rows.Count, 9).End(xlUp).Offset(1).PasteSpecial xlPasteValues
                    End If
                End If
            End If
        Next ws
        Application.CutCopyMode = False
    
        If sh.Range("I2").Value = "" Then Exit Sub
        Set rngDates = sh.Range("I2:I" & sh.Range("I2").CurrentRegion.Rows.Count + 1)
        Set rngTotal = sh.Range("J2:J" & sh.Range("J2").CurrentRegion.Rows.Count + 1)
        Set rngFine = sh.Range("M2:M" & sh.Range("J2").CurrentRegion.Rows.Count + 1)
    
        With sh.Range("E4:E" & sh.Cells(Rows.Count, 4).End(xlUp).Row)
            .Formula = "=SUMPRODUCT(--(MONTH(" & rngDates.Address & ")=MONTH(D4))*(YEAR(" & rngDates.Address & ")=YEAR(D4)),--(" & rngTotal.Address & "))"
            .Offset(, 1).Formula = "=SUMPRODUCT(--(MONTH(" & rngDates.Address & ")=MONTH(D4))*(YEAR(" & rngDates.Address & ")=YEAR(D4)),--(" & rngFine.Address & "))"
            .Offset(, 2).Formula = "=SUM(E4:F4)"
            .Resize(, 2).Value = .Resize(, 2).Value
        End With
    
        sh.Columns("I:M").ClearContents
        Application.Goto sh.Range("A1")
    Application.ScreenUpdating = True
End Sub

 

[حسين مامون]

السلام عليكم 

استاذي خليل  ابو البراء

جزاك الله خيرا الكود ممتاز يعمل كما اريد بالظبط بس اريد ان اقول لما لا تضع مثل هذه الافكار في منشوراتك باليوتوب والفيسبوك .

يعني *نتيجة اجمالي كذا صفحة في صفحة واحدة* مع شرح الاكواد بالعربية

حفظك الله اخي  وارجو  من الله ان ينور قلبكم  وان ينعم عليكم بالصحة  والهناء

الموضوع الاخير طبقته على ملف يحتوي اكثر من 250 صفحة عمل  يعجبني لانه خفيف ومظبوط 

ولن أنسى اخي واستاذنا زيزو العجوز  جزاه الله خيرا  ادامه الله في خدمتنا كوده يعمل وضعته في ملف اخر يحتوي 30 صفحة عمل وهو ايضا مظبوط قبل ان اضعه في هذا الملف جربته على الملف الكبير  يعمل ولكن ثقيل لذلك حولته الى الملف دو30 ص

ادامكم الله في خدمة هذا الصرح العظيم 

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

[حسين مامون]

استاذي المحترم

خليل ابو البراء

 السلام عليكم ورحمة الله

ماذا نغير في الكود ادا اصبح المدى في شيتات  من g9:j

(فقط لاستفاذة)

تحياتي

Nouveau Archive WinRAR (2).rar

[ياسر خليل أبو البراء]

وعليكم السلام أخي الكريم حسين

بارك الله فيك ومشكور على كلماتك الطيبة

الكود بسيط جداً وليس معقد كما تعتقد .. فكرة الكود عمل حلقة تكرارية لأوراق العمل داخل المصنف (وقد قدمت فيديو لذلك) ، مع استثناء أوراق عمل معينة وقد أشرت إلى تلك النقطة في مشاركة سابقة حيث يوضع الشرط بعد بداية الحلقة وقبل نهاية الحلقة .. وما بين أسطر الحلقات يتم نسخ البيانات في أعمدة مساعدة تحددها بنفسك ففي المثال الأصلى استخدمت العمود I إلى M يمكن استخدام أي أعمدة بعيدة عن البيانات ...

 

حدد السطر التالي

Application.CutCopyMode = False

ثم اضغط F9 من لوحة المفاتيح ونفذ الكود لهذا السطر فقط .. ستجد أن البيانات تم نسخها من أوراق العمل المختلفة إلى العمود رقم 9 .. قم بتغيير الرقم 9 إلى أي رقم عمود آخر 

Feuil1.Cells(Rows.Count, 9).End(xlUp).Offset(1).PasteSpecial xlPasteValues

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

بعد ذلك تم الاعتماد على الأعمدة المساعدة في تحقيق المطلوب من خلال معادلات Sumproduct

أرجو ان يفي الشرح بالغرض إن شاء الله

[حسين مامون]

الف الف شكر استاذ 

نعم فهمت هذا

ولكن انا اتكلم عن تغيير  المدى  في الشيتات المرقمة  انظر  المرفق في مشاركتي السابقة ، تم نقل البيانات في كل الصفحات الى مدى g9:j 

تشكر

[حسين مامون]

السلام عليكم

استاذي المحترم خليل ابو البراء

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

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

Sub Test2()
    Dim ws          As Worksheet
    Dim sh          As Worksheet
    Dim rngDates    As Range
    Dim rngTotal    As Range
    Dim rngFine     As Range
    Dim rngFine2     As Range

    Application.ScreenUpdating = False
        Set sh = Feuil1
        For Each ws In ThisWorkbook.Worksheets
            If ws.Name <> "الرئيسية" And ws.Name <> "namodaj" And ws.Name <> "طباعة" Then
                If ws.Name <> sh.Name Then
                    If ws.Range("g9").Value <> "" Then
                        ws.Range("g9:j" & ws.Cells(Rows.Count, "g").End(xlUp).Row).Copy
                        Feuil1.Cells(Rows.Count, 9).End(xlUp).Offset(1).PasteSpecial xlPasteValues
                    End If
                End If
            End If
        Next ws
        Application.CutCopyMode = False
    
        If sh.Range("I2").Value = "" Then Exit Sub
        Set rngDates = sh.Range("I2:I" & sh.Range("I2").CurrentRegion.Rows.Count + 1)
        Set rngTotal = sh.Range("J2:J" & sh.Range("J2").CurrentRegion.Rows.Count + 1)
        Set rngFine = sh.Range("k2:k" & sh.Range("k2").CurrentRegion.Rows.Count + 1)
            Set rngFine2 = sh.Range("L2:L" & sh.Range("L2").CurrentRegion.Rows.Count + 1)

        With sh.Range("E4:E" & sh.Cells(Rows.Count, 4).End(xlUp).Row)
            .Formula = "=SUMPRODUCT(--(MONTH(" & rngDates.Address & ")=MONTH(D4))*(YEAR(" & rngDates.Address & ")=YEAR(D4)),--(" & rngTotal.Address & "))"
            .Offset(, 1).Formula = "=SUMPRODUCT(--(MONTH(" & rngDates.Address & ")=MONTH(d4))*(YEAR(" & rngDates.Address & ")=YEAR(d4)),--(" & rngFine.Address & "))"
                   .Offset(, 2).Formula = "=SUMPRODUCT(--(MONTH(" & rngDates.Address & ")=MONTH(d4))*(YEAR(" & rngDates.Address & ")=YEAR(d4)),--(" & rngFine2.Address & "))"

          
          '.Offset(, 2).Formula = "=SUM(E4:F4)"
            .Resize(, 3).Value = .Resize(, 3).Value
        End With
    
     sh.Columns("I:M").ClearContents
        Application.Goto sh.Range("A1")
    Application.ScreenUpdating = True
End Sub

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

 

[ياسر خليل أبو البراء]

وعليكم السلام أخي الكريم حسين

الكود بهذا الشكل مع الملف الجديد لا أعتقد أنه صحيح إذ يلزم أن تكون الأعمدة المساعدة بعيدة عن مجال البيانات ..

قم بالتعديل وتجربة الكود وانظر هل النتائج صحيحة أم لا؟

حاول تدرس الكود وتفهم الأسطر المكتوبة لتستطيع أن تعدل عليه ، وإذا واجهك سطر غير واضح أخبرنا وسنقوم بشرحه إن شاء العلي القدير

[حسين مامون]

ان شاء الله ساتحقق وارسل النتيجة

[حسين مامون]

استاذي  ياسر خليل أبو البراء

جربته وهو يعمل  انظر المرفق

 

Nouveau Archive WinRAR (3).rar

[ياسر خليل أبو البراء]

تمام الله ينور عليك أخي العزيز حسين

الحمد لله الذي بنعمته تتم الصالحات والتعديل على الكود سيكسبك خبرة أكثر ومع الوقت ستتمكن من كتابة الأكواد بنفسك 

تقبل تحياتي

[حسين مامون]

اخي الفضل لله اولا ولحضرتكم امانا فامامي الكثير والكثير من الاجتهاد لعمل مثل هذه الاكواد على كل حال اشكرك من كل قلبي .

لو سمحت ارسل لي رابط الفيديو الذي وضعته عن الموضوع

تحياتي

[ياسر خليل أبو البراء]

إليك رابط القناة حاول تتابعها وتستفيد منها بأكبر قدر وإن شاء الله مع الوقت تقدر تكتب أكواد بنفسك .. الموضوع ما هو إلا ممارسة وتدريب وتطبيق (ما ولدنا من بطون أمهاتنا وكنا نعرف كتابة الأكواد بل تعلمناها بمرور الوقت مع التدريب والممارسة)

YasserKhalil ExcelLover

[حسين مامون]

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

واصل مثل  هذه الدروس لان بطريفة الفيديو يمكن لاي مبتدئ الاستفاذة والتعلم

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

[ياسر خليل أبو البراء]

وجزيت خيراً بمثل ما دعوت لي أخي الكريم حسين والحمد لله أن نال الفيديو إعجابك وأرجو أن يكون واضح ومفيد للجميع لأننا نريد إحداث طفرة في طريقة التفكير في البرمجة

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