الاشعار بقرب انتهاء العقود

[خالد الرشيدى]

اخي الكريم

جزاك الله خيرا على هذا الدعاء الطيب جزاك الله بمثله ان شاء الله

--- التعديل لم يتناول غير هذا الجزء من الكود ---

تقبل خالص تحياتي 

[ناصر سعيد]

هذا هو الملف

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

او التاريخ المحدد والتواريخ التي تسبقه

لعل احد يستفيد منه

 

تنبيـــــهات بتعديلات خالد الرشيدي.rar

[inas aly]

جراك الله كل خير  استاذ خالد الرشيدي

الملف تمام فقط

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

وصفحه الاشعارات من الصف السادس

في ملف الاخير المرفق من استاذ باصر

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

[خالد الرشيدى]

السلام  عليكم

شكرا جزيلا على هذا الدعاء الطيب وجزيتم بمثله 

والشكر  لصاحب الكود فلم اقم سوي بتعديل الشرط -- فجزاه الله عنا خيراً 

اليكي الملف بعد التعديل المطلوب وبه شرح الكود -- عله يمثل إضافه لمن اراد تغيير نطاق البيانات فيمكنه تعديل الكود

تنبيـــــهات بتعديلات خالد الرشيدي.rar

 

[ناصر سعيد]

Sub ExpiredDate()
' التعريف بالمتغيرات
    Dim LastRow As Integer
    Dim LastRow2 As Integer
    Dim Datecounter As Integer
    Dim SnNo As Integer
    Dim Mtype As String
    Dim Cname As String
    Dim Idate As Date
    Dim PhNo As String
    Dim Adrs As String
    Dim Nvisit As Date
    ' وبها عدد الايام Worksheets("الواجهه").Range("A1") ليساوي القيمة الموجوده بالخليه   expd  تعيين قيمة المتغير
    ' المراد تشغيل التنبيه بعدها
    expd = Worksheets("الواجهه").Range("A1")
    'Date ليساوي تاريخ اليوم  MyDate تعيين قيمة المتغير
    MyDate = Date
    ' قيمه مبدئية للمتغير = 0  هذا المتغير يعبر عن عدد نتائج البحث
    Datecounter = 0
    ' من نتائج البحث القديم لاستقبال نتائج البحث الجديد .Range("A7:G1001") تفريغ النطاق
    Worksheets("الاشعارات").Range("A7:G1001").ClearContents
    'ليساوي صفر وهو الشكل الذي يظهر به عدد النتائج وذلك ايضاً لتهيئته لاستقبال الرقم الجديد Counterlbl ايضا ارجاع ال
    Worksheets("الواجهه").Counterlbl.Caption = 0
    'امرا ً طبيعيا ان نحدد نطاق البيانات التى سيتعامل معها الكود ولكي يتم هذا الامر نحن نعرف صف البدايه ولا نعرف صف نهايه البيانات
    ' ولهذا وجب استخدام احد الاكواد لتحديد صف نهايه البيانات
    LastRow = Worksheets("بيانات أساسيه").Range("A6").End(xlDown).Row
    ' صف نهايه البيانات LastRow حلقه من خلالها نجعل الكود يقوم بالبحث بدءا من الصف السادس وهو صف بدايه البيانات الي
    ' والمحدد قيمته من خلال الكود السابق
    ' بدايه الحلقه الصف السادس وبعد ذلك وبعد التحقق منه وتنفيذ ما هو اتي زكره سترجع مره اخري لتفحص الصف السابع وهكذا -
    ' بمعني ان الكود سيرجع الى هذه النقطه مره اخرى وكانها ساقيه ترجع وتذهب الى نقطه البدايه حتي الانتهاء من كافة الصفوف
    'LastRow والمحدده هنا من الصف السادس الى اخر صف به بيانات
    
    For irow = 6 To LastRow
     
        With Worksheets("بيانات أساسيه")
            
            'في حاله تساوي تاريخ الاستحقاق مع تاريخ اليوم
            '  If (.Cells(irow, 7) - MyDate) >= expd Then

            'في حاله اظهار التواريخ المتساويه والاقل من تاريخ اليوم
            
            If (MyDate - .Cells(irow, 7)) <= expd And (MyDate - .Cells(irow, 7)) > 0 Then

                ' اذا تحقق هذا الشرط بهذا السطر سنقوم بتخزين قيم هذا الصف داخل متغيرات لنسخها بعد ذلك الى صفحه الاشعارات
                ' يعبر عن رقم الصف المنطبق عليه الشرط و الاعداد من واحد الي سبعة يعبر عن الاعمدة irow حيث
                SnNo = .Cells(irow, 1)
                Mtype = .Cells(irow, 2)
                Cname = .Cells(irow, 3)
                Idate = .Cells(irow, 4)
                PhNo = .Cells(irow, 5)
                Adrs = .Cells(irow, 6)
                Nvisit = .Cells(irow, 7)
                ' زياده عداد النتائج ب 1
                Datecounter = Datecounter + 1
                'Datecounter تعيين قيمة الشكل الموجود ب شيت الواجهه الذي يعبر عن عددالنتائج ليساوي قيمة المتغير
                Worksheets("الواجهه").Counterlbl.Caption = Datecounter

                'Moving data.................
                With Worksheets("الاشعارات")
                 ' اول صف فارغ في شيت الاشعارات يمكننا نسخ البيانات اليه
                    LastRow2 = Worksheets("الاشعارات").Cells(.Rows.Count, "A").End(xlUp).Row + 1
                    ' نسخ البيانات
                    .Cells(LastRow2, 1) = SnNo
                    .Cells(LastRow2, 2) = Mtype
                    .Cells(LastRow2, 3) = Cname
                    .Cells(LastRow2, 4) = Idate
                    .Cells(LastRow2, 5) = PhNo
                    .Cells(LastRow2, 6) = Adrs
                    .Cells(LastRow2, 7) = Nvisit
                 ' انتهاء عمليه النسخ
                End With
                ' نهايه جمله الشرط
            End If
            ' انتهي البحث من الصف المحدد
        End With
    '  هنا نقطه نهايه الساقيه عن اللفه الاولي اى الصف السادس بدءا من اختبار الشرط به
    ' وتخزين قيمة داخل متغيرات حال تحقق الشرط به ونسخها الى صفحه الاشعارات
    ' وتبدأ الان لفه جديده ويذهب الكود لاعلي مره اخري عند نقطه البدايه
    ' For irow = 6 To LastRow
    ' ولكن هذه المره لفحص الصف السابع
    ' وعند الانتهاء منه ويوصل الكود لهذه النقطه سيرجع الى نقطه البايه لفحص الصف الثامن وهكذا
     'End Sub لن يذهب الكود الى نقطه البداية  مره اخرى وانما سيذهب لتنفيذ السطر التالى  LastRow وعند الوصول الى اخر صف به بيانات
    Next irow
    
    'انتهي
End Sub

ربنا يبارك لك استاذ خالد .... الكود مع الشرح للمحترم استاذ خالد الرشيدي

[inas aly]

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

من فصلك هذا الملف ممتاز فيه التنيبه باللون الاحمر قيه حطا

ارجو يصحيحه

 

تنســــــــــــــــــــــقات-نسخة.rar

[inas aly]

الخطأ قي التنسيق الشرطي للون الاحمر فقط

[خالد الرشيدى]

السلام  عليكم

بل الخطأ في معادله اللون الاحمر ومعادله اللون الاصفر -- لان اللون الاصفر هنا يحدد التواريخ التى هي اقل من تاريخ اليوم بعدد الايام الموضوعه في حين ان الصحيح ان يحدد التواريخ التى اكبر من تاريخ اليوم بعدد الايام الموضوعه ليكون اللون الاصفر بمثابه انذار بقرب ميعاد الانتهاء والتواريخ الإقل مطبق عليها اللون الاحمر

تنســــــــــــــــــــــقات-نسخة.rar

[ناصر سعيد]

ربنا يبارك لك استاذ خالد ...

[خالد الرشيدى]

السلام عليكم

وبارك لك اخي الكريم... شكرا جزيلا اخي ناصر علي هذا المرور الطيب 

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