برنامج الديون

[hussam alhamadani]

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

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

 

شاهد المرفق لتعرف اكثر

ملاحظة / شاهد الرقة الثانية تشبه الورقة الاولى ولكن الفرق الوحيد هو خانة تاريخ الطلب وهو المطلوب

ديون.rar

[hussam alhamadani]

للرفع ؟؟

[hussam alhamadani]

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

[طارق محمود]

السلام عليكم 

أخي الكريم

الكود التالي في حدث تنشيط الورقة الثانية

 

Private Sub Worksheet_Activate()
Application.ScreenUpdating = False
[A4:G9999].ClearContents
With Sheets(1)
    .AutoFilterMode = False
    LR = .[A9999].End(xlUp).Row
    x = "<" & Format(Date, "mm/dd/yyyy")
    With .Range("A3:G" & LR)
        .AutoFilter Field:=7, Criteria1:="="
        .AutoFilter Field:=6, Criteria1:=x
    End With
    nLR = .[A9999].End(xlUp).Row
    .Range("A3:G" & nLR).Copy
    .AutoFilterMode = False
End With


    [A9999].End(xlUp).Offset(1, 0).Select
    Selection.PasteSpecial Paste:=xlPasteValues
    Range("A4:G4").Delete Shift:=xlUp
    [A2].Select
Application.ScreenUpdating = True
End Sub

وتفضل المرفق ، به أيضا تنسيق شرطي بالورقة الأولي

ديون2.rar

[hussam alhamadani]

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

(مطلوب تاريخ الطلب يظهر بعد شهر من تحديد  تاريخ السداد )

 

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

 

ديون.rar

[أبو حنــــين]

السلام عليكم

جرب هذا الكود

Sub sCopyTo()

Dim Last As Long, x As Long
Application.ScreenUpdating = False
Last = ورقة1.Cells(Rows.Count, "A").End(xlUp).Row
x = 4
For i = 4 To Last
If DateDiff("d", CDate(ورقة1.Cells(i, 6)), Now) <= 0 Then
        ورقة1.Range("a" & i).Resize(1, 6).Copy
        ورقة2.Range("a" & x).PasteSpecial xlPasteValues
        ورقة2.Range("a" & x) = x - 3
        ورقة2.Range("g" & x) = DateAdd("m", 2, ورقة1.Cells(i, 6))
        Application.CutCopyMode = False
        x = x + 1
  End If
Next i
Application.ScreenUpdating = True

End Sub

[طارق محمود]

تفضل

 

ديون3.rar

[hussam alhamadani]

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

[عادل ابوزيد]

الاساتذه الافاضل الكرام

الباشمهندس طارق

الاستاذ ابو حنين

بارك الله فيكم ولكم وعليكم وزادكم من فضله ونعمه