ترقيم حجرات الامتحان تلقائيا في الشيت

[احمد الحاوي]

اخواني الاعزاء في المنتدى الغالي اوفيسنا و منتدى الاكسيل الممتع 

ياريت لو فيه معادلة او كود يقوم بعمل المطلوب في الملف المرفق 

وجزاكم الله خير الجزاء

ترقيم تلقائي.rar

[الـعيدروس]

السلام عليكم

اقتباس

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

هل تقصد اضافة عمود يقوم بعمل مسلسل حسب رقم الحجره ؟

واذا كان المقصد المسلسل في عمود رقم الحجره كيف اعرف هذا الاسم ينتمي لأي حجره !

 

جرب هذا الكود حسب فهمي لطلبك

Sub Ali_Num()
Dim Sw As Worksheet
Dim R, Rb, Rb_To, Vl, i
Set Sw = ورقة1
With ورقة18
For R = 5 To .Cells(.Rows.Count, 1).End(xlUp).Row
If .Cells(R, 1) <> Empty Then
   Rb = Val(.Cells(R, 3))
   Rb_To = Val(.Cells(R, 4))
   Vl = Val(.Cells(R, 1))
 For i = Rb To Rb_To
   Sw.Cells(i + 1, "I") = Vl
 Next
End If
Next
End With
End Sub

 

[ياسر خليل أبو البراء]

أخي الحبيب أبو نصار

أعتقد أنه لا داعي لاستخدام الحلقات التكرارية المتداخلة حيث أن ذلك يبطيء من عمل الكود ...

جرب الكود بهذا الشكل ولاحظ الفرق في سرعة تنفيذ الكودين

Sub Ali_Num()
    Dim SW As Worksheet
    Dim R, Rb, Rb_To, Vl, i
    Set SW = ورقة1
    With ورقة18
        For R = 5 To .Cells(.Rows.Count, 1).End(xlUp).Row
            If .Cells(R, 1) <> Empty Then
                Rb = Val(.Cells(R, 3))
                Rb_To = Val(.Cells(R, 4))
                Vl = Val(.Cells(R, 1))
                SW.Cells(Rb + 1, "I").Resize(Rb_To - Rb + 1) = Vl
            End If
        Next
    End With
End Sub

 

[الـعيدروس]

صحيح اخي ياسر 

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

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

 

 

  

[احمد الحاوي]

الاستاذ / العيدروس ( ابو نصار ) جزيت الخير من رب العالمين  على اهتمامك بالرد

فلك مني كل الشكر والتحية 

استاذنا الاستاذ ياسر ( ابو البراء ) : ماشاء الله .. كود رائع يفي بالمطلوب تماما ..

جزاك الله خيرا .. وزادك علما ونشاطا لخدمة الاعضاء ..لك كل التحية والتقدير

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

ترقيم تلقائي.rar

[ياسر خليل أبو البراء]

Sub Ali_Num()
    Dim WS As Worksheet
    Dim R, RB, RB_To, Vl, I
    
    Set WS = ورقة1
    With ورقة18
        I = .Range("H4").Value
        For R = 5 To .Cells(.Rows.Count, 1).End(xlUp).Row
            If .Cells(R, 1) <> Empty Then
                RB = Val(.Cells(R, 3))
                RB_To = Val(.Cells(R, 4))
                Vl = Val(.Cells(R, 1))
                WS.Cells(RB - I + 2, "I").Resize(RB_To - RB + 1) = Vl
            End If
        Next
    End With
End Sub

أخي الكريم أحمد الحاوي

ليس من أبدع كمن عدل ..الكود يظل باسم معلمي أبو نصار

إليك التعديل البسيط ليؤدي الغرض

 

 

[ابراهيم الحداد]

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

بعد اذن اساتذتى الاجلاء

الحل باستخدام المعادلات والاستعانة ببعض الاعمدة الاضافية

 

ترقيم تلقائي.rar

[احمد الحاوي]

الاساتذة الفضلاء : ابي نصار وزيزو   و   ابي البراء .. لكم مني كل الثناء ..

فنحن الى جواركم :نتعلم الف باء .. اذهب الله عنا جميعا كل بلاء