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

[abouelhassan]

اخوانى الاساتذة الافاضل احبابى

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

فى نهاية الشهر اكتب التاريخ مثلا 30/5 وبخانة البيان اكتب كلمةالاجمالى 

فيقوم التقرير باستدعاء البيانات بدلالة كلمة الاجمالى

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

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

تقرير.xls

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

1- تم تغيير اسماء الصفحات اى اللغة الأجنبية لسهولة نسخ الكود ولصقه 

2-تم التعديل على الجدول  في صفحة ("Report_Youmi") بحيث يكون مستقلاً عن باقي الخلايا (ادراج عامودين فارغين H  و  B  و صف فارغ رفم 2)

3- عملية الجمع تتم حسب التاريخ وليس حسب كلمة اجمالي ( فاذا كان التاريخ في العمود الأول من اي صفحة لا يستوفي شروط بين التاريخين في                   صفحة Report_Youmi  لا يحتسب

4-كل ما عليك فعله هو وضع الأسماء الخقيقية في الجدول (صفحة "Report_Youmi") و تغيير اسماء الصفحات بالأسماء الخقيقية(بالضبط دون مسافات زائدة أو ناقصة ) الأفضل استعمال (Copy  Paste)

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

6- The code

Option Explicit
Sub Trasfer_data()
Dim R          As Worksheet, Act_sh As Worksheet
Dim k%, col%, Ro%, Max_ro%, x%, y%
Dim Bol        As Boolean
Dim ST_Dat     As Date
Dim End_Dat    As Date
Dim My_sum#

Set R = Sheets("Report_Youmi")
Ro = R.Cells(Rows.Count, 1).End(3).Row
R.Range("C3").CurrentRegion.ClearContents
ST_Dat = Application.Min(R.Range("I2:J2"))
End_Dat = Application.Max(R.Range("I2:J2"))

For k = 3 To Ro
      Bol = Application.Evaluate _
        ("ISREF('" & R.Range("A" & k) & "'!A1)")
    If Bol Then
        Set Act_sh = Sheets(R.Range("A" & k) & "")
        Max_ro = Act_sh.Cells(Rows.Count, 1).End(3).Row
        For y = 3 To 7
            For x = 2 To Max_ro - 1
                If CDate(Act_sh.Cells(x, 1)) >= ST_Dat And _
                   CDate(Act_sh.Cells(x, 1)) <= End_Dat Then
                   My_sum = My_sum + IIf(IsNumeric(Act_sh.Cells(x, y + 2)), _
                     Act_sh.Cells(x, y + 2), 0)
               End If
            Next x
             R.Cells(k, y).Value = My_sum: My_sum = 0
       Next y
    End If
Next k

End Sub

الملف مرفق

 

TakRir_Yuomi.xlsm

[abouelhassan]

استاذى ومعلمى سليم حاصبيا والله يعجز لسانى عن شكرك 

وادعوا لك عن ظهر الغيب باستمرار والله ربنا يحفظك يبارك فى عمرك ويعطيك كل خير الدنيا اللهم امين يارب

حضرتك حبيبى والله

نفذت كل التعليمات ولكن توقف الكود عند هذين السطرين

                If CDate(Act_sh.Cells(x, 1)) >= ST_Dat And _
                   CDate(Act_sh.Cells(x, 1)) <= End_Dat Then

كل التقدير والشكر وخالص الدعاء لحضرتك

حفظك الله وحفظ ال بيتك اجمعين

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

تأكد ان الخلايا I2 & J2  والغامود الأول في كل صفحة بتنسيق Date

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

ارفع الملف للمعاينة

[abouelhassan]

هذا هو الملف الصحيح

حفظك الله

تقرير.xls

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

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

My_Repport.xlsm

[abouelhassan]

بارك الله لك وبك استاذى الحبيب

تم اسندعاء التقرير تمام بس وقف الكود عند السطرين

      Bol = Application.Evaluate _
        ("ISREF('" & R.Range("A" & k) & "'!A1)")

حفظك الله

وكمان حضرتك بعد مااضفت الكود لملفى لاحظت

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

انا اسف استاذى الحبيب

هنا استاذنا فى الشيت1

المجموع 550 بينما التقرير 450

حبيبى يا استاذ سليم اسف والله انى ازعجك بطلباتى

My_Repport.xlsm

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

اجذف الناقص 1 من هنا (يمكن الاحتفاظ بها في حال وجود الاجمالي في كل صفحة)

 

[abouelhassan]

استاذنا سليم حاصبيا

الله يرضى عليك استاذنا بعد مسح رقم 1

الكود يستدعى تمام وف الاخر يخرج رسالة ايرور اضغط end

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

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

وبردوا الكود اخرج رسالة run time error13

عندما اضغط عليه يظهر السطرين الاتتين بالاصفر

      Bol = Application.Evaluate _
        ("ISREF('" & R.Range("A" & k) & "'!A1)")

معلش استاذى وحبيبى سامحنى والله 

بارك الله فى حضرتك اللهم امين

 

New Microsoft Word Document.docx

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

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

For x = 2 To Max_ro - 1

و (في حال عدم وجود الاجمالي) 

For x = 2 To Max_ro

بالنسبة للخطأ جرب استبدال هذا السطر

("ISREF('" & R.Range("A" & k) & "'!A1)")

بهذا

("ISREF('" & R.Range("A" & k )&"" & "'!A1)")

ملاحظة اخرى

انت تدرج ارقاماً لاسماء الصفحات 

جرب ان تدرج نصوصاً مثل Amin  ,Kamel  ,Mouhammed  الخ....

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

هذا يتعلق بمكان وجود كلمة اجمالي (اقصد في اى عامود)

ارفع نموذج بسيط عما تريد (صفحتين لا أكثر  لمعرفة سير الكود) تحتوي على بيانات و بدون زركشة ألوان

[abouelhassan]

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

كل شكرى وتقديرى واحترامى

استاذنا بارك الله فيك 

My_Repport.xlsm

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

تم ادراج ماكرو جديد يقوم بما تريد

Option Explicit

Sub Trasfer_data_Special()
Dim R          As Worksheet, Act_sh As Worksheet
Dim k%, col%, Ro%, Max_ro%, x%, y%
Dim Bol        As Boolean
Dim ST_Dat     As Date
Dim End_Dat    As Date
Dim My_sum#
Dim Mot$
Mot = "الاجمالى"

Set R = Sheets("Report_Youmi")
Ro = R.Cells(Rows.Count, 1).End(3).Row
R.Range("C3").CurrentRegion.ClearContents
ST_Dat = Application.Min(R.Range("I2:J2"))
End_Dat = Application.Max(R.Range("I2:J2"))

For k = 3 To Ro

      Bol = Application.Evaluate _
        ("ISREF('" & R.Range("A" & k) & "'!A1)")
    If Bol Then
        Set Act_sh = Sheets(R.Range("A" & k) & "")

        Max_ro = Act_sh.Cells(Rows.Count, 1).End(3).Row
        For y = 3 To 7
            For x = 5 To Max_ro

                If CDate(Act_sh.Cells(x, 1)) >= ST_Dat And _
                   CDate(Act_sh.Cells(x, 1)) <= End_Dat And _
                   Act_sh.Cells(x, 2) <> Mot Then
                   My_sum = My_sum + IIf(IsNumeric(Act_sh.Cells(x, y + 2)), _
                     Act_sh.Cells(x, y + 2), 0)
               End If
            Next x
             R.Cells(k, y).Value = My_sum: My_sum = 0
       Next y
    End If
Next k

End Sub

الملف مرفق

 

My_Repport_Final.xlsm

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

تم تحسين الكود قليلاً لتكون النتيجة اكثر فائدة

Option Explicit

Sub Trasfer_data_Special()
  Dim R          As Worksheet, Act_sh As Worksheet
  Dim k%, col%, Ro%
  Dim Max_ro%, x%, y%
  Dim Bol        As Boolean
  Dim ST_Dat     As Date
  Dim End_Dat    As Date
  Dim My_sum#
  Dim Mot$
  
Mot = "الاجمالى"

Set R = Sheets("Report_Youmi")
Ro = R.Cells(Rows.Count, 1).End(3).Row
R.Range("C3").CurrentRegion.Resize(Ro - 1).ClearContents
R.Cells(3, 9).Resize(Ro + 1).ClearContents

R.Cells(Ro + 1, 9).Resize(2).ClearContents
ST_Dat = Application.Min(R.Range("I2:J2"))
End_Dat = Application.Max(R.Range("I2:J2"))

For k = 3 To Ro

      Bol = Application.Evaluate _
        ("ISREF('" & R.Range("A" & k) & "'!A1)")
    If Bol Then
        Set Act_sh = Sheets(R.Range("A" & k) & "")

        Max_ro = Act_sh.Cells(Rows.Count, 1).End(3).Row
        For y = 3 To 7
            For x = 5 To Max_ro

                If CDate(Act_sh.Cells(x, 1)) >= ST_Dat And _
                   CDate(Act_sh.Cells(x, 1)) <= End_Dat And _
                   Act_sh.Cells(x, 2) <> Mot Then
                   My_sum = My_sum + IIf(IsNumeric(Act_sh.Cells(x, y + 2)), _
                     Act_sh.Cells(x, y + 2), 0)

               End If
               
            Next x
            R.Cells(k, y).Value = My_sum: My_sum = 0
       Next y
    End If
Next k

R.Cells(Ro + 1, 3).Resize(, 5).Formula = _
"=Sum(C$3:C$" & Ro - 2 & ")"

R.Cells(3, 9).Resize(Ro - 1).Formula = _
"=IF(COUNTA($C3:$G3)>0,SUM($C3:$G3),"""")"

R.Cells(Ro + 2, 9) = "Sum Of All"

R.Range("A3:I" & Ro + 2).Value = _
R.Range("A3:I" & Ro + 2).Value
End Sub

الملف مرفق

My_Repport_Final_1.xlsm

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

لم ار الأعجاب على اخر مشاركة حتى الآن

[abouelhassan]

استاذنا انا اسف

واجهتنى مشكلة فى المجموع النهائى

عايز اغير المعادلة أنها تجمع من الصف الرابع وليس من الصف الثالث 

معادلة sum of oll

حاجة جميلة بس عايز اعدل فيها محتاج شرح ازى 

اختار إلى محتاج أجمعه فيها

والله انا اسف ليك اوى اوى اوى

حبيبي

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

غير هذه السطور في الكود

R.Cells(Ro + 1, 3).Resize(, 5).Formula = _
"=Sum(C$3:C$" & Ro - 2 & ")"

R.Cells(3, 9).Resize(Ro - 1).Formula = _
"=IF(COUNTA($C3:$G3)>0,SUM($C3:$G3),"""")"

الى

R.Cells(Ro + 1, 3).Resize(, 5).Formula = _
"=Sum(C$4:C$" & Ro - 2 & ")"

R.Cells(4, 9).Resize(Ro - 2).Formula = _
"=IF(COUNTA($C4:$G4)>0,SUM($C4:$G4),"""")"

 

[abouelhassan]

 

استاذنا حاولت فى المعادلات وحاولت اعدل عليها فشلت

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

الله يرضى عنك

اخيك بمنتهى الاحترامMy_Repport_Final_1.xlsm

تم تعديل مايو 21, 2020 بواسطه abouelhassan

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

من قال لك ان تزيل هذا العامود الفارغ

مم يسبب في اشكال في الكود

 

[abouelhassan]

لم ازيله يا باشا موجود مخفى تمام

حفظك الله ونجاك وأدام عليك نعمه

انا فقط حاولت تعديل المعادلات وفشلت

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

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

My_Repport_Updated.xlsm

[abouelhassan]

الله الله الله الله عليك يا استاذنا 

كود ولا اروع بس مشكلة بسيطو عايز الجمع الى هو 

Global Sum عايزه يكون فى الصف47و 48 هو الان فى الصف 34و34  كل الحب والاحترام وتقديرى الشديد لسعة صدرك ربنا يكرمك يا رب استاذى وحبيبى

[abouelhassan]

تمام تمام تمام كنت ناسى اكتب مجموع 1 ومجموع 2

ممكن استاذنا نغير كلمة 

Global Sum بالجمع عادى للصف مع خالص شكرى وتقديرى

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

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

انا صراحة لا أحب الكتابة باللغة العربية داخل الكود