اذهب الي المحتوي
أوفيسنا
بحث مخصص من جوجل فى أوفيسنا
Custom Search

تعديل على كود تلوين الخلية المتساوية مع أخرى من نفس العمود

أبوســـارة1973

بواسطه أبوســـارة1973
في منتدى الاكسيل Excel

 مشاركة

الردود الموصى بها

أبوســـارة1973

أبوســـارة1973

قام بنشر
قام بنشر (معدل)

Private Sub Worksheet_Change(ByVal Target As Range)

Dim cell As Range

For Each cell In Range("n8:v80")

If cell.Value = "" Then

cell.Interior.ColorIndex = xlNone

End If

If cell.Value <> "" Then

Select Case cell.Value

case cell = cell then

cell.Interior.ColorIndex = 4

End Select

End If

Next

End Sub

------------------------------------------------------

هذا كود يقوم بتلوين الخلية في حالة إدخال قيمة متساوية مع قيمة خلية أخرى في نفس العمود من المدى المحدد(n8:v80)

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

فمن يعدل الكود جزاه الله عني خير الجزاء ؟

تم تعديل بواسطه abusarah73
رابط هذا التعليق
شارك
عبدالله باقشير

عبدالله باقشير

قام بنشر
قام بنشر (معدل)

السلام عليكم

تم عمل كود يتناسب مع طلبك

Private Sub Worksheet_Change(ByVal Target As Range)

Dim R As Integer, C As Integer

If Not Intersect(Target, Range("N8:V80")) Is Nothing Then

If Target.Count > 1 Then Target.Interior.ColorIndex = xlNone: Exit Sub

    Target.Interior.ColorIndex = xlNone

    If Target.Value = "" Then Exit Sub

    For R = 8 To 80

        If R <> Target.Row And Target = Cells(R, Target.Column) Then

            Target.Interior.ColorIndex = 4

        End If

    Next

End If

End Sub

تفضل المرفق

تلوين خلية في عمود بشرط.rar

تم تعديل بواسطه خبور خير
رابط هذا التعليق
شارك
أبوســـارة1973

أبوســـارة1973

قام بنشر
  • الكاتب
قام بنشر

ألف شكر لك أستاذي العزيز خبور

كنت واثقاً بأنك من سيساعدني في تعديل هذا الكود

ولكن اسمح لي بأن أطلب منك أكثر فلقد لاحظت ما يلي :

1- أن هذا الكود يقوم بتلوين كل الخلايا التي تتساوى في قيمهما ماعدا الخلية التي أدخلت أولاً .(مطلوب تلوينا أيضا )

2- عند حذف أو تغير قيمة الخلية التي أدخلت أولاً فإنه لا يقوم بإعادة الخلايا( التي أدخلت بعد ثانياأو ثالثاً أو ...) لوضعها الطبيعي ( بدون تلوين ).

أي لو أدخلنا في الخلية a10 رقم 1 ثم أدخلنا في الخلية a20 رقم 1 فيقوم بتلوين الخلية رقم a20 فقط ولا يلون الخلية a10 ولو حذفنا الرقم 1 أو بدلناه إلى الرقم 11 فتبقى الخلية رقم a20 ملونة والملطلوب هنا حذف التلوين وإعادتها لوضعها الطبيعي .

مع خالص شكري واعذرني إذا أثقلت عليك بعض الشيء

أخوك أبو سارة

رابط هذا التعليق
شارك
عادل حنفي

عادل حنفي

قام بنشر
قام بنشر (معدل)

السلام عليكم

اخي abusarah73

اضافة لحل الاستاذ والاخ الحبيب خبور

الحل بطريقة اخري للافاده

الكود:

Private Sub Worksheet_Change(ByVal Target As Range)

If Target.Row < 8 Then Exit Sub

If Target.Row > 80 Then Exit Sub

If Target.Column < 14 Then Exit Sub

If Target.Column > 22 Then Exit Sub

h = Target.Value

x = Target.Column

L = Target.Row

s = Target.Address

If h <> "" Then

For i = 8 To 80

If Cells(i, x).Value <> "" Then

If Cells(i, x).Row <> L Then

If Cells(i, x).Value = h Then

Cells(i, x).Interior.ColorIndex = 4

GoTo 1

Else

Target.Interior.ColorIndex = xlNone

End If

End If

End If

Next

Exit Sub

1:

Range(s).Select

Range(s).Interior.ColorIndex = 4

End If

End Sub

خالص تحياتي

تحديد خلايا بلون عند التشابه1.rar

تم تعديل بواسطه aah_aah2008
رابط هذا التعليق
شارك
عبدالله باقشير

عبدالله باقشير

قام بنشر
قام بنشر

السلام عليكم

الشكر واصل للاخ/ عادل

الاخ/ ابو سارة

أي لو أدخلنا في الخلية a10 رقم 1 ثم أدخلنا في الخلية a20 رقم 1 فيقوم بتلوين الخلية رقم a20 فقط ولا يلون الخلية a10 ولو حذفنا الرقم 1 أو بدلناه إلى الرقم 11 فتبقى الخلية رقم a20 ملونة والملطلوب هنا حذف التلوين وإعادتها لوضعها الطبيعي .

تم تعديل الكود حسب طلبك :

Private Sub Worksheet_Change(ByVal Target As Range)

Dim R As Integer, C As Integer

If Not Intersect(Target, Range("N8:V80")) Is Nothing Then

    Application.ScreenUpdating = False

    C = Target.Column

    For R = 8 To 80

        If Cells(R, C) <> "" And Application.CountIf(Range(Cells(8, C), Cells(80, C)), Cells(R, C)) > 1 Then

            Cells(R, C).Interior.ColorIndex = 4

        Else

            Cells(R, C).Interior.ColorIndex = xlNone

        End If

    Next

    Application.ScreenUpdating = True

End If

End Sub

شاهد المرفق

تلوين خلية في عمود بشرط.rar

رابط هذا التعليق
شارك
عادل حنفي

عادل حنفي

قام بنشر
قام بنشر (معدل)

السلام عليكم

اخي جرب المرق

الشرح داخل الملف

و تم استخدام الكود التالي


Private Sub Worksheet_SelectionChange(ByVal Target As Range)

If Target.Column <> 1 Then Exit Sub

Application.ScreenUpdating = False

If Range("a1") = "*" Then

GoTo 1

Else

GoTo 2

End If

1:

Application.ScreenUpdating = False

Range("A2:A50").Interior.ColorIndex = 4

Application.ScreenUpdating = True

Exit Sub

2:

Application.ScreenUpdating = False

Range("A2:A50").Interior.ColorIndex = xlNone

Application.ScreenUpdating = True

End Sub

جرب و اخبرني النتيجة

تحياتي

COLUMN COLOR.rar

تم تعديل بواسطه aah_aah2008
رابط هذا التعليق
شارك
ايت الحبيب

ايت الحبيب

قام بنشر
قام بنشر (معدل)

السلام عليكم

اخي جزاك الله بخير إلا انني ساطلب منك تعديلا بسيطا هو ان يطبق هذا الكود على مجموعة من الأعمدة مثلا من A الى AE وتقبل مني خالص التحية والتقدير

تم تعديل بواسطه aitlahbib
رابط هذا التعليق
شارك
عادل حنفي

عادل حنفي

قام بنشر
قام بنشر

السلام عليكم

اخي الكود بعد التعديل وفقا لطلبك


Private Sub Worksheet_SelectionChange(ByVal Target As Range)


If Target.Column <> 1 Then Exit Sub

Application.ScreenUpdating = False

If Range("a1") = "*" Then

GoTo 1

Else

GoTo 2

End If

1:

Application.ScreenUpdating = False

Columns("a:ae").Interior.ColorIndex = 4

Application.ScreenUpdating = True

Exit Sub

2:

Application.ScreenUpdating = False

Columns("a:ae").Interior.ColorIndex = xlNone

Application.ScreenUpdating = True

End Sub

مرفق ملف بالتعديل

COLUMN COLOR.rar

  • Thanks 1
رابط هذا التعليق
شارك
ايت الحبيب

ايت الحبيب

قام بنشر
قام بنشر

السلام عليكم

جزاك الله بخير على هذه المجهوكات التي تقدمها لي الا انني لم اتمكن من ان اوصل لك غايتي :

انا ارغب في ما يلي :

- كلما وضعت (*) في اول العمود A1 يلون العمود من A2 الى A50 فقط

- كلما وضعت (*) في اول العمود B1 يلون العمود من B2 الى B50 فقط

- كلما وضعت (*) في اول العمود C1 يلون العمود من C2 الى C50 فقط

وهكذا الى غاية العمود AE

يمكن ألا يلون عمود من هذه الاعمدة اذا لم اضع النجمة في اوله.

وشكرا وسامحني على تعبك

رابط هذا التعليق
شارك
عادل حنفي

عادل حنفي

قام بنشر
قام بنشر (معدل)

السلام عليكم

اخي abusarah73

مشكور اخي علي كلماتك

اخي aitlahbib

شوف الملف المرفق و اخبرني النتيجه

والكود المستخدم هو


Private Sub Worksheet_Selectionchange(ByVal Target As Range)

If Target.Column > 31 Then Exit Sub

Application.ScreenUpdating = False

x = Target.Column


If Cells(1, x).Value = "*" Then

GoTo 1

Else

GoTo 2

End If

1:

m = Cells(2, x).Address

n = Cells(50, x).Address

Application.ScreenUpdating = False

Range(m, n).Interior.ColorIndex = 4

Application.ScreenUpdating = True

Exit Sub

2:

m = Cells(2, x).Address

n = Cells(50, x).Address

Application.ScreenUpdating = False

Range(m, n).Interior.ColorIndex = xlNone

Application.ScreenUpdating = True

End Sub

تحياتي

column color.rar

تم تعديل بواسطه aah_aah2008
رابط هذا التعليق
شارك

من فضلك سجل دخول لتتمكن من التعليق

ستتمكن من اضافه تعليقات بعد التسجيل



سجل دخولك الان
 مشاركة
الذهاب الي قائمه المواضيع

  • تصفح هذا الموضوع مؤخراً   0 اعضاء متواجدين الان

    • لايوجد اعضاء مسجلون يتصفحون هذه الصفحه
×
×
  • اضف...

Important Information

  I accept