تم المطلوب من قبل الأستاذ حسين مأمون بكود جديد على منتدى أوفيسنا 
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



 

 

 
 
 
 

Hussein Mamoun
 

 
 
 

 
 
 

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 ​
 

 
 

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

أين الضغط على  الإعــــــجـــــاب لهذه الإجابة الممتازة ... وهذا اقل ما يقدم بكثير لصاحب الفضل عليك بعد ربنا فى حل مشكلتك وتفريج كربتك ؟!!!!! 
 
 
 
My love is permanent
 
 
 

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

أين الضغط على  الإعــــــجـــــاب لهذه الإجابة الممتازة ... وهذا اقل ما يقدم بكثير لصاحب الفضل عليك بعد ربنا فى حل مشكلتك وتفريج كربتك ؟!!!!! 
 
 
 
The admiration
 
 
 
 
 
 
 
Well, Mr. Yasser, an excellent answer, may God bless you and may God extend your livelihood My love is permanent Where is the pressure on admiration for this excellent answer ... and this is much less than what is offered to the one who is credited with you after our Lord for solving your problem and relieving your distress? !!!!!
 
 
 

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




Private Sub CommandButton2_Click()

Dim ws As Worksheet: Set ws = Sheets("inpout1")

Dim lr As Integer

Dim R, Ahe3b$, Hather$

 Ahe3b = "غ": Hather = "حاضر"

 ws.Range("ai5:ai500").ClearContents

lr = ws.Range("b" & Rows.Count).End(xlUp).Row

 For R = 5 To lr

  If ws.Cells(R, "B") <> vbNullString Then

     If Application.CountIf(ws.Cells(R, "H").Resize(, 15), Ahe3b) >= 6 Then

        ws.Cells(R, "AI") = "غائب"

     Else

        ws.Cells(R, "AI") = Hather

     End If

  End If

 Next R

 End Sub

​


 
 

 
 

 

 
 

 
 

 
 
Salim Hasbaya

 
 
 

 

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

 مراد

فين انت من كل هذه الإجابات الممتازة ,أين الضغط على الإعـــــــجــــاب ؟!!! وهل جزاء الإحسان الا الإحسان !!!

 وعليكم السلام ... عنوان مخالف للمشاركة فلابد ان يكون العنوان معبر عن مضمون المشاركة

كما انه لابد لكل مشاركة طلب واحد وليس أكثر من ذلك

كما نبهنا مراراً وتكراراً انه لا يمكن المساعدة بدون ملف .... فرجاءاً لا تنتظر المساعدة من احد بدون رفع ملف مدعوم بشرح كافى عن المطلوب فلا يمكن العمل على التخمين وتجنباً لعدم اهدار وقت الأساتذة دون جدوى أو أهمية

 Hassanask
 فين انت من هذه الإجابة الممتازة.... بارك الله فيك استاذ سليم دائماً مبدع ؟!!!

أين الضغط على الإعجاب ؟!!!

 وعليكم السلام-تفضل لا يمكن عمل أكثر من هذا بهذا الكود

Sub SheetMenu()

    Application.CommandBars("Workbook tabs").ShowPopup

End Sub

 لمشاهدة الروابط يلزمك التسجيل في أكاديمية الصقر للتدريب

 

 وعليكم السلام-بالطبع اخى الكريم هذا ممنوع فهذه حقوق ملكية لصاحبها فقط

فان كان يريد ان تكون مفتوحة ومكفولة للجميع فلما شفرها ؟!!!

فهذه جهود المبرمج وهو الوحيد الذى له الحق فى ذلك -فعليك بالإنصال مباشرة بمبرمج هذا العمل

 وعليكم السلام-لا تنتظر المساعدة من احد بدون رفع ملف مدعوم بشرح كافى عن المطلوب ووضع شكل النتائج المرجوة

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