تلوين القيم المتطابقة

[وسيم العش]

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

 

بالمرفق ملف لجدول توقيت الدخول والخروج للعاملين

 

أريد تلوين القيم المتطابقة ( بكل صف على حدة ) , وكل قيمة بلون مغاير للقيمة السابقة .

 

مثلا بالصف الاول المطلوب تلوين القيمة المتطابقة الاولى بلون اصفر , ثم القيمة الثانية بلون أحمر , .....

 

ما وصلت به في الملف هو تلوين القيم المتطابقة جميعها بلون واحد , ولم استطع تلوين كل قيمة متطابقة بنفس الصف بلون مغاير .

 

بانتظار حلكم

 

ولكم كل الشكر

CLR_DUP.rar

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

السلام عليكم

 

جرب التعديل التالي

Sub CLR_DUP()
Dim v, cc
On Error Resume Next
Dim r As Integer, c As Integer
Set ww = Application.WorksheetFunction

Application.ScreenUpdating = False

Range("C3:AN33").Interior.Color = xlNone
v = 9846527
For r = 3 To 33
    For c = 3 To 38
        If ww.CountIf(Range(Cells(r, 3), Cells(r, 38)), Cells(r, c).Value) > 1 Then
            Cells(r, c).Interior.Color = v
            For Each cc In Range(Cells(r, 3), Cells(r, c))
                If cc.Value = Cells(r, c).Value Then
                    Cells(r, c).Interior.Color = cc.Interior.Color
                Else
                v = v + 10000
                End If
          Next
      End If
    Next
Next

Application.ScreenUpdating = True
On Error GoTo 0

End Sub

المرفق 2010

CLR_DUP.rar

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

السلام عليكم

 

او هذا اسرع وافضل

Sub CLR_DUP()
Dim v, cc
On Error Resume Next
Dim r As Integer, c As Integer
Set ww = Application.WorksheetFunction

Application.ScreenUpdating = False

Range("C3:AN33").Interior.Color = xlNone
v = 9846527
For r = 3 To 33
    For c = 3 To 38
        If ww.CountIf(Range(Cells(r, 3), Cells(r, 38)), Cells(r, c).Value) > 1 Then
            Cells(r, c).Interior.Color = v
            For Each cc In Range(Cells(r, 3), Cells(r, c))
                If cc.Value = Cells(r, c).Value Then
                    Cells(r, c).Interior.Color = cc.Interior.Color
                    Exit For
                End If
            Next
            v = v + 10000
        End If
    Next
Next

Application.ScreenUpdating = True
On Error GoTo 0

End Sub

[محمد ابو البـراء]

رائع علامتنا واستاذنا /عبدالله باقشير

جعله الله في ميزان حسناتك

:fff: :fff: :fff:

[شوقي ربيع]

السلام عليكم

تحية لك استادي عبد الله باقشير

لي سؤال بسيط

ماذا لو اردنا ان يتم  المطلوب بنفس الطريقة لكن على الجدول بأكمله وليس حسب كل صف

تم تعديل يوليو 4, 2013 بواسطه دغيدى

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

السلام عليكم

تحية لك استادي عبد الله باقشير

لي سؤال بسيط

ماذا لو اردنا ان يتم  المطلوب بنفس الطريقة لاكن على الجدول بأكمله وليس حسب كل صف

 

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

 

التعديل في هذا السطر فقط

For Each cc In Range(Cells(3, 3), Cells(r, c))

وهذا الكود بعد التعديل

Sub CLR_DUP()
Dim v, cc
On Error Resume Next
Dim r As Integer, c As Integer
Set ww = Application.WorksheetFunction

Application.ScreenUpdating = False

Range("C3:AN33").Interior.Color = xlNone
v = 9846527
For r = 3 To 33
    For c = 3 To 38
        If ww.CountIf(Range(Cells(r, 3), Cells(r, 38)), Cells(r, c).Value) > 1 Then
            Cells(r, c).Interior.Color = v
            For Each cc In Range(Cells(3, 3), Cells(r, c))
                If cc.Value = Cells(r, c).Value Then
                    Cells(r, c).Interior.Color = cc.Interior.Color
                    Exit For
                End If
            Next
          v = v + 10000
      End If
    Next
Next

Application.ScreenUpdating = True
On Error GoTo 0

End Sub

تحياتي

[شوقي ربيع]

10/10

شكرا جزيلا استادي الكريم

[وسيم العش]

أستاذي عبد الله باقشير

 

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

[أبو أنس80]

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

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

السلام عليكم

هذا تعديل على الكود اسرع

Sub kh_AddColr()
Dim v, ww
Dim r As Integer, c As Integer, cc As Integer
Set ww = Application.WorksheetFunction
On Error Resume Next

Application.ScreenUpdating = False

v = 9846527

With Range("C3:AN33")
    .Interior.ColorIndex = xlNone
    For r = 1 To .Rows.Count
        For c = 1 To .Columns.Count
            If ww.CountIf(.Rows(r), .Cells(r, c).Value) > 1 Then
                cc = ww.Match(.Cells(r, c).Value, .Rows(r), 0)
                If cc < c Then
                    .Cells(r, c).Interior.Color = .Cells(r, cc).Interior.Color
                Else
                    .Cells(r, c).Interior.Color = v
                    v = v + 10000
                End If
            End If
        Next
    Next
End With
Application.ScreenUpdating = True
On Error GoTo 0

End Sub

تحياتي