هل يمكن جعل أي خلية تحتوي رقم متكرر تكون بلون مختلف؟

[رحااال]

هل يمكن جعل أي خلية تحتوي رقم متكرر تكون بلون مختلف؟

 

مثل الصورة المرفقة لكن تكون تلقائية لأن الصورة المرفقة عملتها يدوياً (بمعنى أي رقم يتكرر تتحول الخلية الى اللون المشابه)

وشكراً لكم

[Ali Mohamed Ali]

السلام عليكم بها نبدأ أى مشاركة -بما انك لم تقم برفع ملف -فيمكنك استخدام هذا الكود لطلبك:

Sub ColorCompanyDuplicates()

Dim xRg As Range
Dim xTxt As String
Dim xCell As Range
Dim xChar As String
Dim xCellPre As Range
Dim xCIndex As Long
Dim xCol As Collection
Dim i As Long
On Error Resume Next
If ActiveWindow.RangeSelection.Count > 1 Then
xTxt = ActiveWindow.RangeSelection.AddressLocal
Else
xTxt = ActiveSheet.UsedRange.AddressLocal
End If
Set xRg = Application.InputBox("please select the data range:", "Kutools for Excel", xTxt, , , , , 8)
If xRg Is Nothing Then Exit Sub
xCIndex = 2
Set xCol = New Collection
For Each xCell In xRg
On Error Resume Next
If xCell.Value <> "" Then
xCol.Add xCell, xCell.Text
If Err.Number = 457 Then
xCIndex = xCIndex + 1
Set xCellPre = xCol(xCell.Text)
If xCellPre.Interior.ColorIndex = xlNone Then xCellPre.Interior.ColorIndex = xCIndex
xCell.Interior.ColorIndex = xCellPre.Interior.ColorIndex
ElseIf Err.Number = 9 Then
MsgBox "Too many duplicate companies!", vbCritical, "Kutools for Excel"
Exit Sub
End If
On Error GoTo 0
End If
Next
End Sub

 

[رحااال]

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

صدقت وجزاك الله خير ،، لكن بسبب الاستعجال نسيت السلام

 شكراً

الكود ضبط لكن أحتاج أطبقه في كل مرة، لا يحدث تلقائياً

[Ali Mohamed Ali]

تفضل هذا الملف .على الرغم ان كان عليك من البداية رفع ملف بالمشاركة فلا تعنى أى مشاركة شيء بدون ملف يدعمها 

 

 

Colored.xlsb

[عادل ابوزيد]

السلام عليكم .. عندى ملاحظة بعد التجربة .. عند تغيير الرقم او مسحه تحتفظ الخلية بنفس اللون .. مع وافر الشكر والتقدير

 

[محمد هشام.]

 السلام عليكم ورحمة الله تعالى وبركاته بعد ادن الاستاد الكبير @Ali Mohamed Ali

تفضل اخي جرب  

Private Sub Worksheet_Change(ByVal Target As Range)
  
'****************************قم بظبط الاعدادات بما يناسبك********************************
    
    Const Première_ligne      As Long = 2   ' اول صف
    Const PremièreColonne     As String = "A"  'اول عمود
    Const LastColumn          As String = "j"   ' اخر عمود
    Dim R&, lastrow&, J&, Idx&, deling&
    Dim Sp() As String, Ky, Cols As Variant
    Dim dict As Object, Rng As Range, myCells As Range
    
    

'اسم الورقة الخاص بك
    Dim wsdata As Worksheet: Set wsdata = Worksheets("Sheet1")

'(A) ' الى غاية اخر قيمة في عمود
       lastrow = wsdata.Cells(wsdata.Rows.Count, "A").End(xlUp).Row
       ' بدون تقييد
       'lastrow = wsdata.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row

'الخلايا المتأثرة
Set myCells = Intersect(Me.Range("A2:J" & lastrow), Target)

If Not myCells Is Nothing Then
    On Error Resume Next
    deling = wsdata.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    
    ' نطاق البيانات
    Set myRng = wsdata.Range("A2:J" & deling)

'أضف العديد من الألوان كما يحلو لك
Cols = Array(65535, 10086143, 16763904, 15123099, 9359529, 11854022, 32896, 65280, 16711680, 65535, 16711935, _
   16763904, 13434828, 16764057, _
  13408767, 16751052, 10079487)

    Application.ScreenUpdating = False
    Application.EnableEvents = True
    
    Set dict = CreateObject("Scripting.Dictionary")
    With wsdata
    
    '  حدف التنسيقات السابقة
          myRng.Interior.ColorIndex = 0
        
        For J = Columns(PremièreColonne).Column To Columns(LastColumn).Column
       
            If lastrow >= Première_ligne Then
                Set Rng = .Range(.Cells(1, J), .Cells(lastrow, J))
                Arr = Rng.Value
                For R = Première_ligne To lastrow
                    If Len(Arr(R, 1)) Then
                        dict(Arr(R, 1)) = dict(Arr(R, 1)) & "," & _
                                               Cells(R, J).Address
                    End If
                Next R
            End If
        Next J

        For Each Ky In dict
            Sp = Split(dict(Ky), ",")
   '   وضع شرط عدد التكرار لتنفيد الامر
       
       If UBound(Sp) > 1 Then
       
                For K = 1 To UBound(Sp)
                    .Range(Sp(K)).Interior.Color = Cols(Idx)
                Next K
                Idx = Idx + 1
                If Idx > UBound(Cols) Then Idx = LBound(Cols)
            End If
        Next Ky
    End With
    End If

    Application.ScreenUpdating = True

End Sub

 

Test_Couleur.xlsm

[عادل ابوزيد]

السلام عليكم .. جزاك الله كل خير الاستاذ محمد هشام .. تسلم ايدك

بعد اذنك عندى طلب هو تحديد المكرر فى كل عمود على حده .. بمعنى مثلا ادخلت رقم فى العمود a يقوم الكود بالبحث فى العمود a فقط ... ادخلت بيان فى العمود z يقوم الكود بالبحث فى العمود z فقط وهكذا 

تقبل تحياتى وشكرى

[عادل ابوزيد]

المطلوب ان يقوم الكود بالبحث فى العمود الواجد كل عمود منفصل عن العمود الاخر