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

[عامر ياسر]

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

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

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

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

 

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

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

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

6 ساعات مضت, عامر ياسر said:

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

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

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

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

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

[عامر ياسر]

7 ساعات مضت, أبو عبدالإله said:

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

 

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

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

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

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

2 ساعات مضت, ابو عبدالبارى said:

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

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

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

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

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

11 ساعات مضت, عامر ياسر said:

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

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

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

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

[عامر ياسر]

3 ساعات مضت, ابو عبدالبارى said:

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

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

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

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

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

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

اسمح لي بالتعديل قليلاً على الكود المقدم منكم حيث تم جمع الشروط في جملة 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

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

 

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

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

 

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

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

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

16 ساعات مضت, ياسر خليل أبو البراء said:

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

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

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

[عامر ياسر]

17 ساعات مضت, ياسر خليل أبو البراء 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

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

 

 

17 ساعات مضت, ياسر خليل أبو البراء 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

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

 

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

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

 

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

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

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

ود

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

منذ ساعه, سليم حاصبيا 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

ود

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

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