بدون التنسيق الشرطي ... كود لعمل ذلك

[بلانك]

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

 

كود وليس تنسيقات.xlsx

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

السلام عليكم

جرب الكود 

Sub تلوين_المكرر()
    Dim ws As Worksheet, rng As Range, cell As Range
    Dim dict As Object, lastRow As Long
    Dim r As Long, c As Long, key As String
    
    Set ws = ActiveSheet
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    If lastRow < 5 Then lastRow = 5
    
    Set rng = ws.Range("A5:J" & lastRow)
    rng.Interior.ColorIndex = xlNone
    
    Application.ScreenUpdating = False
    
    For r = 5 To lastRow
        For c = 1 To 10
            Set cell = ws.Cells(r, c)
            If Not IsError(cell.Value) And Len(cell.Value) > 0 Then
                key = Trim(cell.Value)
                
                Set dict = CreateObject("Scripting.Dictionary")
                For Each c2 In ws.Range(ws.Cells(r, 1), ws.Cells(r, 10))
                    If c2.Value = key Then dict(key) = dict(key) + 1
                Next
                If dict(key) > 1 Then cell.Interior.Color = vbRed: GoTo NextCell
                
                ' التحقق عموديًا
                dict.RemoveAll
                For Each r2 In ws.Range(ws.Cells(5, c), ws.Cells(lastRow, c))
                    If r2.Value = key Then dict(key) = dict(key) + 1
                Next
                If dict(key) > 1 Then cell.Interior.Color = vbRed
            End If
NextCell:
        Next c
    Next r
    
    Application.ScreenUpdating = True
End Sub

 

تم تعديل منذ 1 ساعه بواسطه عبدالله بشير عبدالله

[بلانك]

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