اضافة ارقام بشرط

[عامر ياسر]

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

اضافة ارقام بشرط.rar

[أبو عبدالإله]

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

 

جرب هذا المرفق لعله المطلوب

اضافة ارقام بشرط.rarFetching info...

[ابو عبدالبارى]

  في 18‏/7‏/2016 at 22:36, عامر ياسر said:

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

اضافة ارقام بشرط.rarFetching info...

Expand  

اخى الكريمعامر ياسر

واثراءاً للموضوع جرب الملف التالى لعلك تجد فيه غايتك

abo_abary_اضافة ارقام بشرط.rar

[عامر ياسر]

  في 18‏/7‏/2016 at 23:59, أبو عبدالإله said:

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

 

جرب هذا المرفق لعله المطلوب

اضافة ارقام بشرط.rarFetching info...

Expand  

الشكر والتقدير ابدعت استاذنا الكريم( أبو عبدالإله )

 في الحل وهذا هو المطلوب زادك الله سبحانه وتعالى علما ً نافعاً .... شكرا .... شكرا .... شكرا .... شكرا .... شكرا .... شكرا .... شكرا .... شكرا .... شكرا .... شكرا .... شكرا .... شكرا 

  في 19‏/7‏/2016 at 05:02, ابو عبدالبارى said:

اخى الكريمعامر ياسر

واثراءاً للموضوع جرب الملف التالى لعلك تجد فيه غايتك

abo_abary_اضافة ارقام بشرط.rarFetching info...

Expand  

شكرا استاذنا الكريم ( ابو عبدالبارى) دائما مبدع وشكرا لك للاجابة على اسئلتي ( استاذنا الكريم الكود لا يعمل بصورة صحيحة لا اعرف الخلل عندي ام وجود خطأ ) معذرةِ 

[ابو عبدالبارى]

  في 19‏/7‏/2016 at 07:33, عامر ياسر said:

شكرا استاذنا الكريم ( ابو عبدالبارى) دائما مبدع وشكرا لك للاجابة على اسئلتي ( استاذنا الكريم الكود لا يعمل بصورة صحيحة لا اعرف الخلل عندي ام وجود خطأ ) معذرةِ 

Expand  

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

abo_abary_اضافة ارقام بشرط.rarFetching info...

تم تعديل يوليو 19, 2016 بواسطه ابو عبدالبارى

[عامر ياسر]

  في 19‏/7‏/2016 at 19:03, ابو عبدالبارى said:

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

abo_abary_اضافة ارقام بشرط.rarFetching info...

Expand  

ابدعت استاذي الكريم ( ابو عبدالبارى)

..الف شكر يا طيب مع احترامي وتقديري لشخصكم 

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

بارك الله فيك أخي العزيز أبو عبد الباري

اسمح لي بالتعديل قليلاً على الكود المقدم منكم حيث تم جمع الشروط في جملة Select Case لثلاثة شروط كنوع من الاختصار (وكمعلومة جديدة للأخوة الأعضاء)

Sub Test()
    Dim I As Integer, Last As Integer
    
    Last = Cells(Rows.Count, "D").End(xlUp).Row
    For I = 6 To Last
        Select Case Range("M" & I)
            Case "ناجح"
                Range("O" & I) = 1
            Case "مكمل بدرس", "مكمل بدرسين", "مكمل بثلاث دروس"
                Range("O" & I) = 2
            Case "راسب"
                Range("O" & I) = 3
        End Select
    Next I
End Sub

تقبلوا تحياتي

 

[أبو عبدالإله]

الشكر لله أخي عامر وجزاك الله كل خير 

 

الفاضلان أبو عبدالباري و أستاذي ياسر إضافتان رائعتان جدا 

دمتم أحبة وبرعاية الله

[ابو عبدالبارى]

  في 20‏/7‏/2016 at 00:12, ياسر خليل أبو البراء said:

Case "مكمل بدرس", "مكمل بدرسين", "مكمل بثلاث دروس"

Expand  

اخى الكريم ياسر خليل أبو البراء

تعودنا فى هذا الصرح الشامخ ومن اساذتنا ان نتعلم كل يوم المزيد لك كل الشكر  وشكرا لمرورك العطر .

[عامر ياسر]

  في 20‏/7‏/2016 at 00:12, ياسر خليل أبو البراء said:

بارك الله فيك أخي العزيز أبو عبد الباري

اسمح لي بالتعديل قليلاً على الكود المقدم منكم حيث تم جمع الشروط في جملة Select Case لثلاثة شروط كنوع من الاختصار (وكمعلومة جديدة للأخوة الأعضاء)

Sub Test()
    Dim I As Integer, Last As Integer
    
    Last = Cells(Rows.Count, "D").End(xlUp).Row
    For I = 6 To Last
        Select Case Range("M" & I)
            Case "ناجح"
                Range("O" & I) = 1
            Case "مكمل بدرس", "مكمل بدرسين", "مكمل بثلاث دروس"
                Range("O" & I) = 2
            Case "راسب"
                Range("O" & I) = 3
        End Select
    Next I
End Sub

تقبلوا تحياتي

 

Expand  

 

  في 20‏/7‏/2016 at 00:12, ياسر خليل أبو البراء said:

بارك الله فيك أخي العزيز أبو عبد الباري

اسمح لي بالتعديل قليلاً على الكود المقدم منكم حيث تم جمع الشروط في جملة Select Case لثلاثة شروط كنوع من الاختصار (وكمعلومة جديدة للأخوة الأعضاء)

Sub Test()
    Dim I As Integer, Last As Integer
    
    Last = Cells(Rows.Count, "D").End(xlUp).Row
    For I = 6 To Last
        Select Case Range("M" & I)
            Case "ناجح"
                Range("O" & I) = 1
            Case "مكمل بدرس", "مكمل بدرسين", "مكمل بثلاث دروس"
                Range("O" & I) = 2
            Case "راسب"
                Range("O" & I) = 3
        End Select
    Next I
End Sub

تقبلوا تحياتي

 

Expand  

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

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

 

[سليم حاصبيا]

اسمحوا لي باضافة هذا الكود

Sub EXEMLPE()

i = 6
Do Until Cells(i, "M") = Empty
 With Cells(i, "M")
    If .Value = "ناجح" Then x = 1 Else x = 0
    If .Value = "مكمل بدرس" Then y = 2 Else y = 0
    If .Value = "مكمل بدرسين" Then t = 2 Else t = 0
    If .Value = "مكمل بثلاث دروس" Then m = 2 Else m = 0
    If .Value = "راسب" Then Z = 3 Else Z = 0
 End With
 Cells(i, "O") = Application.Max(x, y, Z, m, t)
 i = i + 1
 Loop
End Sub

ود

[سليم حاصبيا]

  في 20‏/7‏/2016 at 19:40, سليم حاصبيا said:

اسمحوا لي باضافة هذا الكود

Sub EXEMLPE()

i = 6
Do Until Cells(i, "M") = Empty
 With Cells(i, "M")
    If .Value = "ناجح" Then x = 1 Else x = 0
    If .Value = "مكمل بدرس" Then y = 2 Else y = 0
    If .Value = "مكمل بدرسين" Then t = 2 Else t = 0
    If .Value = "مكمل بثلاث دروس" Then m = 2 Else m = 0
    If .Value = "راسب" Then Z = 3 Else Z = 0
 End With
 Cells(i, "O") = Application.Max(x, y, Z, m, t)
 i = i + 1
 Loop
End Sub

ود

Expand  

اسمحوا لي باضافة هذا الكود

Sub EXEMLPE()

i = 6
Do Until Cells(i, "M") = Empty
 With Cells(i, "M")
    If .Value = "ناجح" Then x = 1 Else x = 0
    If .Value = "مكمل بدرس" Then y = 2 Else y = 0
    If .Value = "مكمل بدرسين" Then t = 2 Else t = 0
    If .Value = "مكمل بثلاث دروس" Then m = 2 Else m = 0
    If .Value = "راسب" Then Z = 3 Else Z = 0
 End With
 Cells(i, "O") = Application.Max(x, y, Z, m, t)
 i = i + 1
 Loop
End Sub

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

Sub EXEMLPE2()
i = 6
Do Until Cells(i, "M") = Empty
 With Cells(i, "M")
    If .Value = "ناجح" Then .Offset(0, 2) = 1: GoTo Nexxt
    If .Value = "مكمل بدرس" Then .Offset(0, 2) = 2: GoTo Nexxt
    If .Value = "مكمل بدرسين" Then .Offset(0, 2) = 2: GoTo Nexxt
    If .Value = "مكمل بثلاث دروس" Then .Offset(0, 2) = 2: GoTo Nexxt
    If .Value = "راسب" Then .Offset(0, 2) = 3
 End With
Nexxt:
 i = i + 1
 Loop
End Sub