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

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


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

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

 

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

 

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

 

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

 

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

 

بانتظار حلكم

 

ولكم كل الشكر

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
  • Like 2
رابط هذا التعليق
شارك

السلام عليكم

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

لي سؤال بسيط

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

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

السلام عليكم

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

لي سؤال بسيط

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

 

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

 

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

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

تحياتي

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

السلام عليكم

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


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

تحياتي

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

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

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



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

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

Important Information