اذهب الي المحتوي
أوفيسنا

تلوين القيم المتكررة رأسيا وأفقيا فى نفس الوقت


إذهب إلى أفضل إجابة Solved by Ali Mohamed Ali,

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

تفضل استاذى الكريم

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

 

تنسيق شرطى للقيم المكررة فى نفس الصف.xlsx

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

جرب هذا الكود

Option Explicit
Sub Colorize_Range()
'Created By Salim Hasbaya 9/6/2109
Dim i%, x%, k%, m%, My_ad$, First_ad$
Dim My_rg As Range, cel As Range
Set My_rg = Range("a1:G12")
Dim f_rg As Range
x = 4
My_rg.Interior.ColorIndex = xlNone
 For Each cel In My_rg
    If cel.Interior.ColorIndex <> xlNone Or _
     Application.CountIf(My_rg, cel) = 1 Then _
     GoTo next_cel
       Set f_rg = My_rg.Find(cel, lookat:=xlWhole)
            My_ad = f_rg.Address: First_ad = My_ad
        Do
          Range(My_ad).Interior.ColorIndex = x
          Set f_rg = My_rg.FindNext(f_rg)
          My_ad = f_rg.Address
       Loop Until My_ad = First_ad
    x = x + 1: If x = 57 Then x = 10
next_cel:
 Next cel
 End Sub

الملف مرفق

 

CororisMe.xlsm

  • Like 3
رابط هذا التعليق
شارك

4 hours ago, أحمد يوسف said:

تفضل استاذى الكريم

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

 

تنسيق شرطى للقيم المكررة فى نفس الصف.xlsx 9.22 kB · 1 download

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

C5:Y30 

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

و إذا تكرر رقم فى نفس الصف يتم تلوين الخلايا المكررة بلوم أزرق

علماً بأن بأن العملية ستتكرر فى مدى آخر و ليكم من
C35:Y60

ولكن إن كان التكرار خارج المدى المحدد لا يتم تلوين الخلايا حتى لو كانت الخلية المكررة فى المدى الآخر

ساقية ر افت - Copy.xls

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

4 hours ago, سليم حاصبيا said:

جرب هذا الكود


Option Explicit
Sub Colorize_Range()
'Created By Salim Hasbaya 9/6/2109
Dim i%, x%, k%, m%, My_ad$, First_ad$
Dim My_rg As Range, cel As Range
Set My_rg = Range("a1:G12")
Dim f_rg As Range
x = 4
My_rg.Interior.ColorIndex = xlNone
 For Each cel In My_rg
    If cel.Interior.ColorIndex <> xlNone Or _
     Application.CountIf(My_rg, cel) = 1 Then _
     GoTo next_cel
       Set f_rg = My_rg.Find(cel, lookat:=xlWhole)
            My_ad = f_rg.Address: First_ad = My_ad
        Do
          Range(My_ad).Interior.ColorIndex = x
          Set f_rg = My_rg.FindNext(f_rg)
          My_ad = f_rg.Address
       Loop Until My_ad = First_ad
    x = x + 1: If x = 57 Then x = 10
next_cel:
 Next cel
 End Sub

الملف مرفق

 

CororisMe.xlsm 20.17 kB · 1 download

الف شكر على تعبك استاذنا الكريم سليم بك
الرجاء تعديل الكود كالآتى
1. ضبط المدى الذى سينفذ فيه الكود بحيث أنه يمكن أن نطلب تنفيذ الكود فى أكثر من مدى  ولكن كل منهما مستقل عن الآخر
2. داخل نفس المدى المحدد إذا تكرر الرقم فى نفس السطر يكون لون الخلايا أزرق و إذا كان التكرار فى نفس العمود يكون لون الخلايا أحمر

ومرفق ملف للتنفيذ عليه حيث عندى أوفيس 2003

و مرفق صورة لشرح نقطة
مثلاً رقم 55 تم تلوين خليته حيث تكرر فى نفس الصف و تكرر كذلك فى نفس العمود
لكن رقم 44 لماذا تم تلوينه ؟؟
لقد تكرر ولكن ليس فى نفس الصف و ليس فى نفس العمود فلم يكن يجب أن يتلون
أتعشم أن الفكرة قد تكون وضحت
تقبل تحياتى

image.png.88ab933fc469d9e630c0c5875f3608fb.png

ساقية ر افت - Copy.xls

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

الف شكر على مجهودك على بك
ربنا يحفظك
هل ممكن إستثناء حرف ال ( ح ) من التنسيق الشرطى ؟

سواء الأفقى أو الرأسى

رابط هذا التعليق
شارك

للرفع رفع الله قدركم

في ١١‏/٦‏/٢٠١٩ at 14:10, Ali Mohamed Ali said:

تفضل استاذى الكريم بالتنسيق الشرطى

 

ساقية.xls 79.5 \u0643\u064a\u0644\u0648 \u0628\u0627\u064a\u062a · 3 downloads

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

رابط هذا التعليق
شارك

في ١٠‏/٦‏/٢٠١٩ at 02:23, يوسف عطا said:

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

و إذا تكرر رقم فى نفس الصف يتم تلوين الخلايا المكررة بلوم أزرق

و ماذا اذا حدث تكرار رأسيا و افقيا لنفس الرقم ، افترض ان الشرط الثاني سيجب الاول اي ستكون الخلية رزفاء ، هل هذا صحيح؟

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

منذ ساعه, محمد طاهر said:

و ماذا اذا حدث تكرار رأسيا و افقيا لنفس الرقم ، افترض ان الشرط الثاني سيجب الاول اي ستكون الخلية رزفاء ، هل هذا صحيح؟

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

رابط هذا التعليق
شارك

جرب الكود التالي ، 

اعتقد انه يمكن اختصاره بعض الشيء ، و لكن اتصور انه يؤدي المطلوب

اولا ظلل الخلايا المطلوب تحليلها ثم شغل الكود و قم باختباره

ملاحظة بعد النشر وضعت الوان مختلفة حيث لم انتبه للون الاصفر و ووضعت بدلا منه اخضر ، يمكنك تعديله كما تشاء علما بان كود اللون الاصفر 65535

 

Sub Color_Dubplicatesl()
' color duplicates hzl adn vl as requested by youssef Atta on 14 june
Dim myrow, mycol As Integer
mycol = Selection.Columns.Count
myrow = Selection.Rows.Count
Selection.Interior.ColorIndex = xlNone

'=================
' Hzl Dubplicate
For i = 0 To myrow - 1
For j = 0 To mycol - 1

If Not IsNull(ActiveCell.Offset(i, j).Value) And ActiveCell.Offset(i, j).Value <> "" Then
If IsNumeric(ActiveCell.Offset(i, j).Value) Then
  
  For k = j + 1 To mycol - 1 ' compare this col
   If ActiveCell.Offset(i, j).Value = ActiveCell.Offset(i, k).Value Then
    ActiveCell.Offset(i, j).Cells.Interior.Color = 255 ' red
    ActiveCell.Offset(i, k).Cells.Interior.Color = 255 ' red
    Exit For
   End If
  Next k ' compare this col
  
  
End If ' if numeric
End If ' not if null

Next j
Next i
'==============
' Vl Duplicates
'=================

For i = 0 To mycol - 1
For j = 0 To myrow - 1

If Not IsNull(ActiveCell.Offset(j, i).Value) And ActiveCell.Offset(j, i).Value <> "" Then
If IsNumeric(ActiveCell.Offset(j, i).Value) Then
  
  For k = j + 1 To myrow - 1 ' compare this col
   If ActiveCell.Offset(j, i).Value = ActiveCell.Offset(k, i).Value Then
    
    If ActiveCell.Offset(j, i).Cells.Interior.Color = 255 Then
    ActiveCell.Offset(j, i).Cells.Interior.Color = 5287936 ' green
    Else
    ActiveCell.Offset(j, i).Cells.Interior.Color = 15773696 ' cyan
    End If
    
    If ActiveCell.Offset(k, i).Cells.Interior.Color = 255 Then
    ActiveCell.Offset(k, i).Cells.Interior.Color = 5287936 ' green
    Else
    ActiveCell.Offset(k, i).Cells.Interior.Color = 15773696 ' cyan
    End If
    
    Exit For
   End If
  Next k ' compare this col
    End If ' if numeric
End If ' not if null
Next j
Next i

End Sub

 

ساقية.xls

  • Like 3
رابط هذا التعليق
شارك

11 ساعات مضت, محمد طاهر said:

جرب الكود التالي ، 

اعتقد انه يمكن اختصاره بعض الشيء ، و لكن اتصور انه يؤدي المطلوب

اولا ظلل الخلايا المطلوب تحليلها ثم شغل الكود و قم باختباره

ملاحظة بعد النشر وضعت الوان مختلفة حيث لم انتبه للون الاصفر و ووضعت بدلا منه اخضر ، يمكنك تعديله كما تشاء علما بان كود اللون الاصفر 65535

 


Sub Color_Dubplicatesl()
' color duplicates hzl adn vl as requested by youssef Atta on 14 june
Dim myrow, mycol As Integer
mycol = Selection.Columns.Count
myrow = Selection.Rows.Count
Selection.Interior.ColorIndex = xlNone

'=================
' Hzl Dubplicate
For i = 0 To myrow - 1
For j = 0 To mycol - 1

If Not IsNull(ActiveCell.Offset(i, j).Value) And ActiveCell.Offset(i, j).Value <> "" Then
If IsNumeric(ActiveCell.Offset(i, j).Value) Then
  
  For k = j + 1 To mycol - 1 ' compare this col
   If ActiveCell.Offset(i, j).Value = ActiveCell.Offset(i, k).Value Then
    ActiveCell.Offset(i, j).Cells.Interior.Color = 255 ' red
    ActiveCell.Offset(i, k).Cells.Interior.Color = 255 ' red
    Exit For
   End If
  Next k ' compare this col
  
  
End If ' if numeric
End If ' not if null

Next j
Next i
'==============
' Vl Duplicates
'=================

For i = 0 To mycol - 1
For j = 0 To myrow - 1

If Not IsNull(ActiveCell.Offset(j, i).Value) And ActiveCell.Offset(j, i).Value <> "" Then
If IsNumeric(ActiveCell.Offset(j, i).Value) Then
  
  For k = j + 1 To myrow - 1 ' compare this col
   If ActiveCell.Offset(j, i).Value = ActiveCell.Offset(k, i).Value Then
    
    If ActiveCell.Offset(j, i).Cells.Interior.Color = 255 Then
    ActiveCell.Offset(j, i).Cells.Interior.Color = 5287936 ' green
    Else
    ActiveCell.Offset(j, i).Cells.Interior.Color = 15773696 ' cyan
    End If
    
    If ActiveCell.Offset(k, i).Cells.Interior.Color = 255 Then
    ActiveCell.Offset(k, i).Cells.Interior.Color = 5287936 ' green
    Else
    ActiveCell.Offset(k, i).Cells.Interior.Color = 15773696 ' cyan
    End If
    
    Exit For
   End If
  Next k ' compare this col
    End If ' if numeric
End If ' not if null
Next j
Next i

End Sub

 

ساقية.xls 78 \u0643\u064a\u0644\u0648 \u0628\u0627\u064a\u062a · 2 downloads

الف شكر استاذنا الغالى
جارى التجربة

10 ساعات مضت, Ali Mohamed Ali said:

عمل رائع استاذ محمد بارك الله فيك

ولإثراء الموضوع هذا حل اخر بدون اكواد

 

ساقية.xls 229 \u0643\u064a\u0644\u0648 \u0628\u0627\u064a\u062a · 0 downloads

الف شكر استاذ على 
جزاك الله خير

  • Like 2
رابط هذا التعليق
شارك

6 ساعات مضت, Ali Mohamed Ali said:

ولإثراء الموضوع هذا حل اخر بدون اكواد

جميل جدا  فالحل بدون كود أفضل عندما يكون متاحا

و احب ان نستمر فى مناقشة حل التنسيق الشرطي، هل يمكن ايضا من خلاله تجديد الخلايا الخضراء ( اي التى بها تكرار رأسي و افقي فى نفس الوقت)

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

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.

زائر
اضف رد علي هذا الموضوع....

×   Pasted as rich text.   Paste as plain text instead

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

×
×
  • اضف...

Important Information