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

[mahmoud nasr alhasany]

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

الرجاء مساعدتى  فى هذه المشكلة يوجد اعمدة بأسماء الاصناف لكل بلد  وتم عمل المطلوب من خلال معادلة اكسيل ومعادلة VBA  من خلال المعادلة المرتبطة بالكود VBA

  =GetUniqueColumns(C3:I3)  

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

Sub FormatUniqueColumnsDirectly()
    Dim ws As Worksheet
    Dim DataRange As Range
    Dim uniqueColsCollection As New Collection ' This will store the unique column letters
    Dim cell As Range
    Dim count As Long
    Dim colLetter As String
    Dim targetColumn As Excel.Range
    Dim i As Long

    ' --- إعداداتك ---
    ' 1. تأكد من أن اسم الورقة صحيح
    Set ws = ThisWorkbook.Sheets("Sheet1") ' غيّر "Sheet1" إلى اسم ورقتك الفعلي

    ' 2. تأكد من أن نطاق البيانات صحيح
    ' هذا النطاق هو الذي سيتم البحث فيه عن القيم الفريدة.
    ' على سبيل المثال، إذا كانت بياناتك في الأعمدة من A إلى Z، ومن الصف 1 إلى الصف 100
    Set DataRange = ws.Range("A1:Z100") ' اضبط هذا على نطاق بياناتك الفعلي

    Debug.Print "Worksheet Name: " & ws.Name
    Debug.Print "Data Range to check for uniqueness: " & DataRange.Address

    ' --- الخطوة 1: تحديد الأعمدة الفريدة بناءً على القيم الفريدة داخل النطاق ---
    ' (هذا هو جوهر ما كانت تفعله دالة GetUniqueColumns)

    For Each cell In DataRange
        ' تأكد من أن الخلية ليست فارغة، وإلا فقد يتم عد الخلايا الفارغة كقيم فريدة
        If Not IsEmpty(cell.Value) Then
            ' حساب عدد تكرارات القيمة في النطاق الكلي
            count = Application.WorksheetFunction.CountIf(DataRange, cell.Value)
            If count = 1 Then ' إذا كانت القيمة فريدة (تظهر مرة واحدة فقط)
                ' الحصول على حرف العمود من عنوان الخلية (مثال: من $C$5 نحصل على C)
                colLetter = Split(cell.Address(True, False), "$")(0)
                Debug.Print "Found unique value: " & cell.Value & " in column: " & colLetter
                On Error Resume Next ' لتجنب الأخطاء إذا تم إضافة نفس حرف العمود بالفعل
                uniqueColsCollection.Add colLetter, CStr(colLetter) ' إضافة حرف العمود إلى المجموعة
                On Error GoTo 0
            End If
        End If
    Next cell

    Debug.Print "Number of unique columns identified: " & uniqueColsCollection.count

    ' --- الخطوة 2: تطبيق التنسيق على الأعمدة الفريدة التي تم تحديدها ---

    If uniqueColsCollection.count > 0 Then
        For Each columnLetter In uniqueColsCollection
            Debug.Print "Attempting to format column: " & columnLetter

            ' الحصول على كائن العمود بالكامل باستخدام حرف العمود
            On Error Resume Next ' في حالة كان حرف العمود غير صالح أو فارغ
            Set targetColumn = ws.Columns(columnLetter)
            On Error GoTo 0

            If Not targetColumn Is Nothing Then
                Debug.Print "Applying formatting to column: " & columnLetter
                ' تطبيق التنسيق على العمود المحدد
                With targetColumn.Interior
                    .Color = RGB(255, 255, 0) ' تعبئة صفراء
                End With
                With targetColumn.Font
                    .Color = RGB(255, 0, 0) ' خط أحمر
                    .Bold = True ' خط عريض
                    .Size = 12 ' حجم الخط
                End With
                ' إضافة حدود للعمود
                With targetColumn
                    .Borders(xlEdgeLeft).LineStyle = xlContinuous
                    .Borders(xlEdgeRight).LineStyle = xlContinuous
                    .Borders(xlEdgeTop).LineStyle = xlContinuous
                    .Borders(xlEdgeBottom).LineStyle = xlContinuous
                    .Borders.Weight = xlThin ' حدود رفيعة
                End With
                targetColumn.ColumnWidth = 15 ' ضبط عرض العمود
                targetColumn.HorizontalAlignment = xlCenter ' محاذاة النص في المنتصف
            Else
                Debug.Print "Error: Could not set targetColumn for letter: " & columnLetter & ". It might be an invalid column letter."
            End If
            Set targetColumn = Nothing ' إعادة تعيين المتغير للتكرار التالي
        Next columnLetter
    Else
        MsgBox "لا توجد أعمدة فريدة لتنسيقها في النطاق المحدد.", vbInformation
    End If

    ' --- تنظيف المتغيرات ---
    Set ws = Nothing
    Set DataRange = Nothing
    Set uniqueColsCollection = Nothing
End Sub

' Keep your GetUniqueColumns function if you still need it for displaying the message
 Function GetUniqueColumns(DataRange As Range) As String
    Dim cell As Range
    Dim uniqueCols As New Collection
    Dim tempArr() As String
    Dim result As String
    Dim i As Long
    Dim colLetter As String
    Dim count As Long

    For Each cell In DataRange
        count = Application.WorksheetFunction.CountIf(DataRange, cell.Value)
        If count = 1 Then
            colLetter = Split(cell.Address(True, False), "$")(0)
            On Error Resume Next
            uniqueCols.Add colLetter, CStr(colLetter)
            On Error GoTo 0
        End If
    Next cell

    If uniqueCols.count = 0 Then
        ReDim tempArr(0 To 0)
    Else
        ReDim tempArr(1 To uniqueCols.count)
        For i = 1 To uniqueCols.count
            tempArr(i) = "العمود " & uniqueCols.Item(i) & " مختلف"
        Next i
    End If

    If UBound(tempArr) = 0 Or uniqueCols.count = 0 Then
        result = ""
    ElseIf UBound(tempArr) = 1 Then
        result = tempArr(1)
    Else
        For i = 1 To UBound(tempArr)
            If i = 1 Then
                result = tempArr(i)
            Else
                result = result & " و " & tempArr(i)
            End If
        Next i
    End If

    GetUniqueColumns = result
 End Function

 

2025 اسم التوكيل.xlsm

[hegazee]

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

أسهل شيء استخدام التنسيق الشرطي

(2)2025 اسم التوكيل.xlsm

[hegazee]

جرب الكود التالي:

Sub CheckDifferences()
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim r As Long
    Dim values(1 To 7) As Variant
    Dim result As String
    Dim i As Integer, j As Integer
    Dim count As Integer
    Dim isFirstDiff As Boolean

    Set ws = ThisWorkbook.Sheets("Sheet1") ' ✏️ غيّر اسم الشيت إذا لزم
    lastRow = ws.Cells(ws.Rows.Count, "C").End(xlUp).Row

    ' تنظيف العمود O قبل الكتابة
    ws.Range("O3:O" & lastRow).ClearContents
    ws.Range("O3:O" & lastRow).Interior.ColorIndex = xlNone
    ws.Range("O3:O" & lastRow).Font.ColorIndex = xlAutomatic

    For r = 3 To lastRow
        ' قراءة القيم من C إلى I
        For i = 1 To 7
            values(i) = ws.Cells(r, i + 2).Value
        Next i

        result = ""
        isFirstDiff = True

        For i = 1 To 7
            count = 0
            For j = 1 To 7
                If values(j) = values(i) Then count = count + 1
            Next j

            If count = 1 Then
                If Not isFirstDiff Then
                    result = result & " و "
                End If
                result = result & "العمود " & Chr(64 + i + 2) & " مختلف"
                isFirstDiff = False
            End If
        Next i

        With ws.Cells(r, 15) ' العمود O
            .Value = Trim(result)
            If result <> "" Then
                .Interior.Color = vbYellow     ' تعبئة باللون الأصفر
                .Font.Color = vbRed            ' الخط باللون الأحمر
            End If
        End With
    Next r
End Sub