تلوين رقمين داخل شبكة أرقام

[مشعل سلطان]

السلام عليكم 

لدي شبكة من الأرقام 

هل هناك طريقة لتلوين الارقام داخل الشبكة عندما أكتب رقمين 

أطلب فيها من البرنامج البحث عنهما

 

أرقام.xls

[محمد هشام.]

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

تفضل جرب اخي 

Sub FindCouleur()

Dim j(1 To 2) As String, F As Variant
Dim a As Range, R As Range, T&, Cpt&, lCol&, lrow&

Dim WS As Worksheet: Set WS = Worksheets("0")

Application.ScreenUpdating = False
lrow = WS.Cells.Find(What:="*", LookIn:=xlValues, SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
lCol = WS.Cells(1, Columns.Count).End(xlToLeft).Column

j(1) = [Al14]: j(2) = [Al15]


    Set a = WS. _
        Range("A1", WS.Cells(lrow, lCol))
                    F = Array(j(1), j(2))

With a
.Interior.ColorIndex = xlNone
    For Cpt = LBound(F) To UBound(F)
        Set R = .Cells(.Cells.Count)
            For T = 1 To WorksheetFunction.CountIf(a, F(Cpt))
                    Set R = .Cells.Find(What:=F(Cpt), LookIn:=xlValues, LookAt:=xlWhole, _
                    After:=R, MatchCase:=False)
                    R.Interior.Color = vbYellow
                    
            Next T
        Next
  End With
Application.ScreenUpdating = True

End Sub

 

 

أرقام.xlsm

تم تعديل ديسمبر 1, 2023 بواسطه محمد هشام.

[مشعل سلطان]

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

كفيت ووفيت

عمل يذكر فيشكر

[محي الدين ابو البشر]

بالاذن من الاستاذ محمد هشام.

طريقة أخرى

Sub test()
Range("A1:AI35").Interior.Color = xlNone
    For I = 14 To 15
        Range("A1:AI35").Cells.Find(Range("AL" & I), , , 1).Interior.Color = vbRed
    Next
End Sub

 

[محمد هشام.]

بارك الله فيك اخي @محي الدين ابو البشر لاكن يجب أخذ في عين الإعتبار وجود نفس القيمة مكررة في أكثر من خلية  على ما أظن 

[محي الدين ابو البشر]

حسناً

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

مع أني لا أعتقد ذلك بحسب المعادلة التي وضعها السيد مشعل

لكن بكل الأحوال ممكن تجربة هذا الكود

Sub test()
    Dim i&
    Dim x As String
    Dim r As Range
    Application.ScreenUpdating = False
    Range("A1:AI35").Interior.Color = xlNone
    For i = 14 To 15
        With Range("A1:AI35")
            Set r = .Cells.Find(Range("AL" & i), , , 1)
            x = r.Address
            Do
                r.Interior.Color = vbRed
                Set r = .Cells.FindNext(r)
            Loop Until r.Address = x
        End With
    Next
    Application.ScreenUpdating = True
End Sub
'وأيضاً لتلوين كل رقم بلون مختلف
Sub test2()
    Dim i&
    Dim x As String
    Dim r As Range
    Dim f As Boolean
    Application.ScreenUpdating = False
    Range("A1:AI35").Interior.Color = xlNone
    For i = 14 To 15
        With Range("A1:AI35")
            Set r = .Cells.Find(Range("AL" & i), , , 1)
            x = r.Address
            Do
                r.Interior.Color = IIf(f, vbRed, vbYellow)
                Set r = .Cells.FindNext(r)
            Loop Until r.Address = x
        End With
        f = True
    Next
    Application.ScreenUpdating = True
End Sub

 

تم تعديل ديسمبر 3, 2023 بواسطه محي الدين ابو البشر

[محمد هشام.]

فقط مجرد احتمال على العموم وفقنا الله واياكم لما يحب ويرضى

كود جميل ومختصر .شكرا لك