أكاديمية الصقر للتدريب

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


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





كود لاضافة سطور حسب الشهر الحالي وعدد الاقساط

السلام عليكم ورحمه الله وبركاته اتمني التعديل على الكود المرفق لكي تتوقف الحلقة التكرارية عند شرط معين (مرفق الملف وبه ش ..


موضوع مغلق


28-02-2021 03:02 مساء
yousef_kaf
عضو فعال
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 25-11-2017
رقم العضوية : 1908
المشاركات : 122
الدولة : مصر
الجنس : ذكر
تاريخ الميلاد : 2-9-1989
يتابعهم : 9
يتابعونه : 3
قوة السمعة : 180
 offline 

السلام عليكم ورحمه الله وبركاته

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

 
 
  الاقساط المستحقة.xlsm   تحميل xlsm مرات التحميل :(6)
الحجم :(18.585) KB



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

Sub test()

Dim lr, lr2, lrw

Dim x, w, dt, rg

Application.ScreenUpdating = False

lr = Cells(Rows.Count, 1).End(xlUp).Row

Range("n6:p10000").ClearContents

For x = 6 To lr

        Set rg = Cells(x, "c")

         dt = Cells(x, "b")

        If Cells(x, "c") >= 1 Then

        lr2 = Cells(Rows.Count, "n").End(xlUp).Row

        For w = 1 To rg

        lrw = Cells(Rows.Count, "p").End(xlUp).Row

         If dt = CDate(Range("p3")) Then GoTo 1

        Range("n" & lrw + 1) = Cells(x, 1)

        Range("O" & lrw + 1).Value = Format(DateAdd("m", 1, dt), "mm-yyyy")

        Range("p" & lrw + 1).Value = rg - 1

         dt = Format(DateAdd("m", 1, dt), "mm-yyyy")

         rg = rg - 1

        Next w

        End If

1: Next x

Application.ScreenUpdating = True



End Sub


 
   
 
 
 
Sub test() Dim lr, lr2, lrw Dim x, w, dt, rg Application.ScreenUpdating = False lr = Cells(Rows.Count, 1).End(xlUp).Row Range("n6:p10000").ClearContents For x = 6 To lr Set rg = Cells(x, "c") dt = Cells(x, "b") If Cells(x, "c") >= 1 Then lr2 = Cells(Rows.Count, "n").End(xlUp).Row For w = 1 To rg lrw = Cells(Rows.Count, "p").End(xlUp).Row If dt = CDate(Range("p3")) Then GoTo 1 Range("n" & lrw + 1) = Cells(x, 1) Range("O" & lrw + 1).Value = Format(DateAdd("m", 1, dt), "mm-yyyy") Range("p" & lrw + 1).Value = rg - 1 dt = Format(DateAdd("m", 1, dt), "mm-yyyy") rg = rg - 1 Next w End If 1: Next x Application.ScreenUpdating = True End Sub ​
 
 
عرض الإجابة




01-03-2021 01:38 مساء
مشاهدة مشاركة منفردة [1]
yousef_kaf
عضو فعال
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 25-11-2017
رقم العضوية : 1908
المشاركات : 122
الدولة : مصر
الجنس : ذكر
تاريخ الميلاد : 2-9-1989
يتابعهم : 9
يتابعونه : 3
قوة السمعة : 180
 offline 
look/images/icons/i1.gif كود لاضافة سطور حسب الشهر الحالي وعدد الاقساط
السلام عليكم
كنت قد طرحت الموضوع فى منتدي اخر
وقام الاستاذ حسين مأمون بالرد عليا
تم ارفاق الكود 
Dim lr, lr2, lrw
Dim x, w, dt, rg
Application.ScreenUpdating = False
lr = Cells(Rows.Count, 1).End(xlUp).Row
Range("n6:p100000").ClearContents
For x = 6 To lr
        Set rg = Cells(x, "c")
        If Cells(x, "c") >= 1 Then
        lr2 = Cells(Rows.Count, "n").End(xlUp).Row
        Range("n" & lr2 + 1).Resize(, 3).Value = Cells(x, 1).Resize(, 3).Value
        For w = 1 To rg
        lrw = Cells(Rows.Count, "p").End(xlUp).Row
'        If Format(Cells(w, "o"), "m") = Format(Range("p3"), "m") Then GoTo 1
        Range("n" & lrw + 1) = Cells(x, 1)
        dt = Range("o" & lrw)
        Range("O" & lrw + 1).Value = Format(DateAdd("m", 1, dt), "mm-yyyy")
        Range("p" & lrw + 1).Value = Range("p" & lrw) - 1
         dt = Format(DateAdd("m", 1, dt), "mm-yyyy")
         If dt = CDate(Range("p3")) Then GoTo 1
        Next w
        End If
1: Next x
Application.ScreenUpdating = True

02-03-2021 02:18 مساء
مشاهدة مشاركة منفردة [2]
أحمد يوسف
عضو ماسي
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 01-03-2018
رقم العضوية : 4669
المشاركات : 483
الجنس : ذكر
الدعوات : 2
يتابعهم : 4
يتابعونه : 11
قوة السمعة : 1129
عدد الإجابات: 6
 offline 
look/images/icons/i1.gif كود لاضافة سطور حسب الشهر الحالي وعدد الاقساط
تم المطلوب من قبل الأستاذ حسين مأمون بكود جديد على منتدى أوفيسنا

Sub test()

Dim lr, lr2, lrw

Dim x, w, dt, rg

Application.ScreenUpdating = False

lr = Cells(Rows.Count, 1).End(xlUp).Row

Range("n6:p10000").ClearContents

For x = 6 To lr

        Set rg = Cells(x, "c")

         dt = Cells(x, "b")

        If Cells(x, "c") >= 1 Then

        lr2 = Cells(Rows.Count, "n").End(xlUp).Row

        For w = 1 To rg

        lrw = Cells(Rows.Count, "p").End(xlUp).Row

         If dt = CDate(Range("p3")) Then GoTo 1

        Range("n" & lrw + 1) = Cells(x, 1)

        Range("O" & lrw + 1).Value = Format(DateAdd("m", 1, dt), "mm-yyyy")

        Range("p" & lrw + 1).Value = rg - 1

         dt = Format(DateAdd("m", 1, dt), "mm-yyyy")

         rg = rg - 1

        Next w

        End If

1: Next x

Application.ScreenUpdating = True



End Sub


 
   
 
 
 
Sub test() Dim lr, lr2, lrw Dim x, w, dt, rg Application.ScreenUpdating = False lr = Cells(Rows.Count, 1).End(xlUp).Row Range("n6:p10000").ClearContents For x = 6 To lr Set rg = Cells(x, "c") dt = Cells(x, "b") If Cells(x, "c") >= 1 Then lr2 = Cells(Rows.Count, "n").End(xlUp).Row For w = 1 To rg lrw = Cells(Rows.Count, "p").End(xlUp).Row If dt = CDate(Range("p3")) Then GoTo 1 Range("n" & lrw + 1) = Cells(x, 1) Range("O" & lrw + 1).Value = Format(DateAdd("m", 1, dt), "mm-yyyy") Range("p" & lrw + 1).Value = rg - 1 dt = Format(DateAdd("m", 1, dt), "mm-yyyy") rg = rg - 1 Next w End If 1: Next x Application.ScreenUpdating = True End Sub ​
 
 



الكلمات الدلالية
لاضافة ، سطور ، الشهر ، الحالي ، وعدد ، الاقساط ،


 










اخلاء مسئولية: يخلى منتدى أكاديمية الصقر للتدريب مسئوليته عن اى مواضيع او مشاركات تندرج داخل الموقع ويحثكم على التواصل معنا ان كانت هناك اى إنتهاكات تتضمن اى انتهاك لحقوق الملكية الفكرية او الادبية لاى جهة - بالتواصل معنا من خلال نموذج مراسلة الإدارة .وسيتم اتخاذ الاجراءات اللازمة.
سياسة النشر: التعليقات المنشورة لا تعبر عن رأي منتدى أكاديمية الصقر للتدريب ولا نتحمل أي مسؤولية قانونية حيال ذلك ويتحمل كاتبها مسؤولية النشر.

الساعة الآن 07:20 مساء