كود ممتاز لتلوين الخلية حسب قيمتها (شرح كود)

[عبد الفتاح كيرة]

السلام عليكم

إخوتى الكرام

قابلنى هذا الكود المحكم و المجرب

لتلوين الخلايا حسب قيمتها

و هو يستخدم فى تمييز الطالب الراسب فى الكنترول شيت

أرجو رأيكم

وملاحظاتكم عليه

Private Sub Worksheet_Change(ByVal Target As Range)


    Dim c As Range, r As Range


    Application.ScreenUpdating = False


    With Me

        Set r = .Range("C4:K39")

        On Error Resume Next

        For Each c In r

            If c.Value <> vbNullString Then

                With c

                    Select Case .Value

                    Case "G"

                        ' Change font color

                        .Font.ColorIndex = 10 ' 10 = Green

                        ' Change background color

                        '.Interior.ColorIndex = 10

                    Case "Y"

                        .Font.ColorIndex = 6 ' 6 = Yellow

                        .Interior.ColorIndex = 6

                    Case Is < 15

                        '.Font.ColorIndex = 3 '3 = Red

                        .Interior.ColorIndex = 3


                    Case Else


                        .Font.ColorIndex = 1 '1 = Black

                        '.Interior.ColorIndex = 2

                    End Select

                End With

            End If

        Next c

    End With


    Set r = Nothing


    Application.ScreenUpdating = True


End Sub

تم تعديل يونيو 6, 2010 بواسطه kemas

[هشام شلبى]

السلام عليكم

===========

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

ولكن سنحاول معا لتطبيقة على اعمدة معينة بدلا من مدى متكامل

تحياتى لك اخى كيماس

[اوفيس 2003]

موضع راااااااااااااائع

هل ممكن من مثال اكثر توضيح

[عبد الفتاح كيرة]

و عليكم السلام أخى هشام

أنا جربت الكود على عمود واحد

Set r = .Range("C4:K39")

نستخدم مثلا

Set r = .Range("C2:c500")

ويمكن اختصار جملة case لتكون حالتين فقط أردت فقط فكرة الكود و هناك أشياء جديدة على فى هذا الكود مثل

 With Me

إشارة للصفحة أو الورقة الموضوع فيها الكود و

If c.Value <> vbNullString Then

طريقة الإشارة للخلية الخالية

أخانا office2003

يخيل لى الكود بهذا صار واضحا

تحيتى لكم

[اوفيس 2003]

استاذ هشام ممكن شرح بالفلاش كعادتك ؟؟

[هشام شلبى]

السلام عليكم

===========

الاخ office 2003

تفضل

office 2003.rar

[هشام شلبى]

السلام عليكم

==========

الاخ kemas

بعد تجربة الكود وجدت به عيب لا يصير مع برامج الكنترول

وهو عند تغير الحالة لا يمحو اللون "اظنك فاهمنى"

فيجب اضافة السطر التالى الى الكود

If Not Intersect(Target, Range("C4:K39")) Is Nothing Then

        Select Case Target

هذا والله اعلم ولكن انظر الى هذا الكود وما له من تعدد فى الحالات ويتغلب على مشكلة محو اللون عند تغير الحالة

Private Sub Worksheet_Change(ByVal Target As Range)

Dim icolor As Integer


    If Not Intersect(Target, Range("A1:F100")) Is Nothing Then

        Select Case Target

            Case "Y"

                icolor = 3

            Case "G"

                icolor = 12

            Case "F"

                icolor = 5

            Case "X"

                icolor = 9

            Case "Z"

                icolor = 3

            Case "áå ÏæÑ ËÇäì Ýì ãæÇÏ"

                icolor = 33

            Case Else

                'ويمكن زيادة الحالات

        End Select


        Target.Interior.ColorIndex = icolor

    End If


End Sub

شاهد المرفق

كود يلون عند ارقام معينة.rar

[قصي]

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

[عبد الفتاح كيرة]

مفهوم أخ هشام

ملاحظة ممتازة

جارى التجربة

ممكن شرح للسطر الذى أضفته و فائدته

If Not Intersect(Target, Range("C4:K39")) Is Nothing Then

        Select Case Target

تم تعديل يونيو 7, 2010 بواسطه kemas

[هشام شلبى]

السلام عليكم

===========

هذا السطر هو الخاص بمحو اللون فى حالة ما اذا كانت الخلية "فى المدى المستهدف" فارغة او لا تحقق الشروط الاتية فيما بعد

[عبد الفتاح كيرة]

لقد حذفت السطر المضاف

والكود يعمل بكفاءة

أعتقد أن هذا السطر فائدته الوحيدة

هى حصر تنفيذ الجمل البرمجية التالية

داخل المدى المحدد فقط

وهو

c4:k39انظر

بعبارة أخرى

حتى لا يرجع إكسل رسالة خطأ

فى حال تحديدنا لخلية خارج النطاق المحدد

Private Sub Worksheet_Change(ByVal Target As Range)

Dim icolor As Integer


         Select Case Target

            Case Is < 15

                icolor = 3

            Case "G"

                icolor = 12

            Case "F"

                icolor = 5

            Case "X"

                icolor = 9

            Case "Z"

                icolor = 3

            Case "له دور ثانى فى مواد"

                icolor = 33

            Case Else

                'ويمكن زيادة الحالات

        End Select


        Target.Interior.ColorIndex = icolor


End Sub

تم تعديل يونيو 7, 2010 بواسطه kemas

[هشام شلبى]

السلام عليكم

===========

اخى kemas

الكود لا يعمل بكفأة ولا حاجة

وهذا الدليل

طبعا انت شايف من المرفق عند المسح لا يتم الغاء اللون

KEMAS.rar

New ورقة عمل Microsoft Excel (2).rar

[جلال محمد]

أخى هشام

تحياتى لك

ارجو من حضرتك تقوم بتطبيق ذلك علي عمودين مختلفين مثلا العمود( A1:A20 ) والعمود ( D1:D20 ) كما في المرفق

وذلك عند كتابة الرقم

Book1.rar

[عبد الفتاح كيرة]

كود أبسط و أسهل

Private Sub Worksheet_Change(ByVal Target As Range)

    If Not Intersect(Target, Range("A1:A100")) Is Nothing Then

        If Target.Value < 15 Then

        Target.Interior.ColorIndex = 3

        Else

        Target.Interior.ColorIndex = 2

        End If

                End If

                If ActiveCell.Value = "" Then

                ActiveCell.Interior.ColorIndex = 2

                End If

End Sub

تم تعديل يونيو 7, 2010 بواسطه kemas

[هشام شلبى]

السلام عليكم

===========

اخى عادل حياك الله

اقرأ المشاركة رقم 2

ولكن الحمد لله توصلت للحل

وسارفقه بعد قليل

تحياتى لك

[عبد الفتاح كيرة]

هذا فيه علاج المشكلة

عند مسح أى خلية

تتلون باللون الأبيض

المناقشات أثمرت خيرا و الحمد لله

Private Sub Worksheet_Change(ByVal Target As Range)

    If Not Intersect(Target, Range("A1:A100")) Is Nothing Then

        If Target.Value < 15 Then

        Target.Interior.ColorIndex = 3

        Else

        Target.Interior.ColorIndex = 2

        End If

                End If

                If ActiveCell.Value = "" Then

                ActiveCell.Interior.ColorIndex = 2

                End If

End Sub

تم تعديل يونيو 7, 2010 بواسطه kemas

[هشام شلبى]

السلام عليكم

===========

اخى kemas

ان شاء الله لا مشاكل لطالما نبحث عن الجديد

بس ما زالت المشكلة موجودة لان اللون الابيض هو لون ولا كلامى غلط

بس ممكن للتغلب على مشكلة المسح باتغيير الاتى بالكود واتمنى ان تجربه

Private Sub Worksheet_Change(ByVal Target As Range)

    If Not Intersect(Target, Range("A1:A100")) Is Nothing Then

        If Target.Value < 15 Then

        Target.Interior.ColorIndex = 3

        Else

        Target.Interior.ColorIndex = 0

        End If

                End If

                If ActiveCell.Value = "" Then

                ActiveCell.Interior.ColorIndex = 0

                End If

End Sub

اليك المرفق عند كتابة العدد ستتلون الخلية وعند المسح سوف تكون بلا لون

كيماس.rar

[الحسامي]

السلام عليكم

موضوع مهم وارجو التوفيق للجميع وحلول اكثر من رائعة

ولاثراء الموضوع هذا كود مسح الخلايا

If IsEmpty(Target.Cells) Then Target.Interior.ColorIndex = 0

[هشام شلبى]

السلام عليكم

===========

تمام يا عمدة

وهذا البديل لها الذى ارفقته فى الكود خاصتى

If ActiveCell.Value = "" Then

                ActiveCell.Interior.ColorIndex = 0

[عبد الفتاح كيرة]

ممتاز جدا أخى هشام

نعم

الأبيض هو لون

و

0

يعنى بدون تعبئة

ممتازة و الكود الآن يعمل بكفاءة

و الحمد لله

لكن يبقى السؤال

لماذا عند ضغط مفتاح

delete

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

لم ينفذ الشرط و تعود الخلية للون العادى يعنى بلا لون

أو حتى أبيض

هل ضغط مفتاح

delete

لا يعتبر تغييرا

يعنى

لا يندرج تحت الحدث

change

هذا هو السؤال

أم أن هناك خطوة فى الكود

تمنع ذلك

أرجو أن يكون سؤالى مفهوما

وشكرا لردودك التى استفدت منها جدا

[عبد الفتاح كيرة]

شكرا للأخ عماد الحسامى

اللمسات الأخيرة ممتازة جدا

إذن

توصلنا للكود النهائى

هذا

' åÐÇ åæ ßæÏ ÇáÊáæíä ÇáäåÇÆí

Private Sub Worksheet_Change(ByVal Target As Range)

    If Not Intersect(Target, Range("A1:A100")) Is Nothing Then

        If Target.Value < 15 Then

        Target.Interior.ColorIndex = 3

        Else

        Target.Interior.ColorIndex = 0

        End If

                End If


              If IsEmpty(Target.Cells) Then Target.Interior.ColorIndex = 0


End Sub

تم تعديل يونيو 7, 2010 بواسطه kemas

[الحسامي]

السلام عليكم

نعم اخي العزيز هشام

الكودان يعطينان نفس النتيجةويحملان نفس المبدأ

لكن يجب التفريق ما بين activecel وما بين target

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

انت ملزم باختار احدهما بالتحديد

target هي الخلية المختارة اي التي نقوم بأختيارها أما

Activecell هي الخلية النشطة أي التى يكون المؤشر عليها فمثلا

عند استخدام الاكواد في حالة Worksheet_Change

activecell هي الخلية التالية بعد الضغط على Enter وليست الخلية المختارة

بعكس Target تبقى الخلية نفسها حتى بعد الضغط على Enter

وللمشاركة معكم هنا ملف بسيط يعطي الناجح لون والراسب لون اخر

تلوين خلية.rar

[جلال محمد]

شكرا للأخ عماد الحسامى

اللمسات الأخيرة ممتازة جدا

إذن

توصلنا للكود النهائى

فعلا كدة تمام

ولكن ارجو من الاخوة تطبيق ذلك علي اكثر من عمود

فالمواد في الشيت تكون كثيرة والتنسيقات الشرطية تختلف من مادة الي اخرى

وجزى الله الجميع الأجر الوفير

[عبد الفتاح كيرة]

أظن نحتاج فقط تغيير المدى

[هشام شلبى]

السلام عليكم

===========

الاخ العزيز galal_mk

طبعا اعرف الغرض من مشاركتك

فعلا كدة تمام

ولكن ارجو من الاخوة تطبيق ذلك علي اكثر من عمود

فالمواد في الشيت تكون كثيرة والتنسيقات الشرطية تختلف من مادة الي اخرى

وجزى الله الجميع الأجر الوفير

واحدة واحدة ان شاء الله نوصل للهفنا المنشود

اولا اطلع على الملف الاتى

وقد طبقت التنسيق الشرطى بالكود على اربع لعمدة مختلفة وغير متجاورة

ويمكن زيادة الشروط لتتلائم مع ما نريدة فى الشيت

تحياتى

شرطى عمود.rar