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

[عاطف عبد العليم محمد]

السلام عليكم ورحمة الله وبركاته 

لدي هذا الكود  واصله من هذا المنتدى ــ اسأل الله ان يغفر لكل من ينفع الناس فيه 

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

Option Explicit
Sub kh_Color1()
Dim Obj As Object
Dim cel As Range
Dim MyColor
Dim MyInteriorColor
Dim txt As String
Dim lr As Long, R As Long, mr As Long


 Application.ScreenUpdating = False
'''''''''''''''''''''''''''''
'''''''''''''''''''''''''''''
Set Obj = CreateObject("Scripting.Dictionary")
'''''''''''''''''''''''''''''
MyColor = 900000
MyInteriorColor = 800444

'''''''''''''''''''''''''''''
Sheets("قيود اليومية").Select
lr = Cells(Rows.Count, "a").End(xlUp).Row
mr = Cells(Rows.Count, "g").End(xlUp).Row

Range("a6:j" & lr).Interior.Color = MyInteriorColor


   Application.ScreenUpdating = False
    For R = 6 To lr
        txt = Trim(Cells(R, "g"))
        If Len(txt) Then
            If Obj.exists(txt) Then
                Range(Cells(R, "a"), Cells(R, "j")).Interior.Color = Obj(txt)
              Else
                Obj.Add txt, MyColor
                Range(Cells(R, "a"), Cells(R, "j")).Interior.Color = MyColor
               
               
                MyColor = MyColor + 7000111
            
            End If
        End If
    Next
Set Obj = Nothing


'''''''''''''''''''''''''''''
Application.ScreenUpdating = True

End Sub

 

[محمد هشام.]

وعليكم السلام ورحمة الله تعالى وبركاته

Option Explicit
Sub kh_Color1()
    Dim Obj As Object, MyColor As Long, lr As Long, R As Long, txt As String
    Dim WS As Worksheet: Set WS = Sheets("قيود اليومية")
    Application.ScreenUpdating = False
    Set Obj = CreateObject("Scripting.Dictionary")
    MyColor = 900000
    lr = WS.Cells(WS.Rows.Count, "A").End(xlUp).Row
    WS.Range("A6:J" & lr).Interior.color = 800444
    For R = 6 To lr
        txt = Trim(WS.Cells(R, "G"))
        If Len(txt) Then
            If Not Obj.Exists(txt) Then
                Obj.Add txt, MyColor
                MyColor = MyColor + 7000111
            End If
            WS.Range(WS.Cells(R, "A"), WS.Cells(R, "J")).Interior.color = Obj(txt)
            Dim rColor As Long, gColor As Long, bColor As Long
            rColor = (Obj(txt) Mod 256)
            gColor = ((Obj(txt) \ 256) Mod 256)
            bColor = ((Obj(txt) \ 65536) Mod 256)
            If (rColor + gColor + bColor) / 3 < 128 Then
                WS.Cells(R, "A").Resize(1, 10).Font.color = RGB(255, 255, 255)
            Else
                WS.Cells(R, "A").Resize(1, 10).Font.color = RGB(0, 0, 0)
            End If
        End If
    Next R
    Set Obj = Nothing
    Application.ScreenUpdating = True
End Sub

 

[عاطف عبد العليم محمد]

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

بارك الله فيكم

تم تعديل فبراير 9, 2025 بواسطه عاطف عبد العليم محمد