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

[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

 

[mahmoud nasr alhasany]

 

 هذا الكود الصحيح بخصوص تنسيق الاعمدة المختلفة من العمود C حتى العمود I

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

 

 

Sub FormatUniqueCellsInRow()
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim r As Long
    Dim values(1 To 7) As Variant ' لتخزين القيم من C إلى I (7 أعمدة)
    Dim i As Integer, j As Integer
    Dim count As Integer

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

    ' 2. تحديد آخر صف يحتوي على بيانات في العمود C
    lastRow = ws.Cells(ws.Rows.count, "C").End(xlUp).Row

    ' 3. تنظيف أي تنسيقات سابقة من الأعمدة C إلى I
    ' هذا مهم لضمان تطبيق التنسيقات الجديدة فقط
    ws.Range("C3:I" & lastRow).Interior.ColorIndex = xlNone ' مسح لون التعبئة
    ws.Range("C3:I" & lastRow).Font.ColorIndex = xlAutomatic ' مسح لون الخط المخصص
    ws.Range("C3:I" & lastRow).Font.Bold = False ' إلغاء الخط العريض

    ' 4. المرور على كل صف بدءًا من الصف 3 (أو أي صف تبدأ منه بياناتك)
    For r = 3 To lastRow ' ابدأ من الصف الذي تبدأ منه بياناتك

        ' قراءة القيم من العمود C إلى I للصف الحالي وتخزينها في مصفوفة
        ' Column C is index 1 (i + 2 where i=1 means 1+2=3 which is C)
        For i = 1 To 7
            values(i) = ws.Cells(r, i + 2).Value ' i+2 لأن C هو العمود الثالث
        Next i

        ' فحص كل قيمة في الصف لتحديد إذا كانت فريدة داخل هذا الصف
        For i = 1 To 7 ' تكرار على كل عمود من C إلى I (بواسطة فهرس المصفوفة i)
            count = 0 ' إعادة تعيين العداد لكل قيمة

            ' مقارنة القيمة الحالية (values(i)) بجميع القيم الأخرى في نفس الصف
            For j = 1 To 7
                If values(j) = values(i) Then
                    count = count + 1
                End If
            Next j

            ' إذا كانت القيمة فريدة (تكررت مرة واحدة فقط في الصف)
            If count = 1 Then
                ' تطبيق التنسيق على الخلية المحددة التي تحتوي على القيمة الفريدة
                With ws.Cells(r, i + 2) ' i + 2 يمثل رقم العمود الفعلي (C, D, E...)
                    .Interior.Color = RGB(255, 255, 0) ' تعبئة صفراء (RGB for exact yellow)
                    .Font.Color = RGB(255, 0, 0)       ' خط أحمر (RGB for exact red)
                    .Font.Bold = True                   ' خط عريض
                End With
            End If
        Next i
    Next r

    ' إذا كنت لا تزال ترغب في الاحتفاظ بالعمود O بالنص الوصفي، يمكنك ترك الكود الخاص بك
    ' Sub CheckDifferences() وتشغيله بعد هذا الكود، أو دمج المنطق هنا.
    ' لكن هذا الكود يركز فقط على تنسيق الخلايا من C إلى I.

End Sub

 

[hegazee]

تفضل

Sub FormatUniqueCellsInRow()
    Dim ws As Worksheet
    Dim lastRow As Long, startRow As Long
    Dim r As Long, i As Long, j As Long
    Dim values(1 To 7) As Variant
    Dim count As Long
    Dim data As Variant

    On Error GoTo ErrorHandler
    Set ws = ThisWorkbook.Sheets("Sheet1") ' تأكد من تغيير "Sheet1" إلى اسم الورقة الفعلي
    startRow = 3 ' الصف الذي تبدأ منه البيانات
    lastRow = ws.Range("C3:I" & ws.Rows.Count).Find(What:="*", _
        SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row

    ' تنظيف التنسيقات السابقة من الأعمدة C:I و O
    With ws.Range("C" & startRow & ":I" & lastRow & ",O" & startRow & ":O" & lastRow)
        .Interior.ColorIndex = xlNone
        .Font.ColorIndex = xlAutomatic
        .Font.Bold = False
    End With

    ' تحميل النطاق إلى مصفوفة
    data = ws.Range("C" & startRow & ":I" & lastRow).Value

    ' المرور على كل صف
    For r = 1 To lastRow - startRow + 1
        ' تخزين قيم الصف الحالي
        For i = 1 To 7
            values(i) = data(r, i)
        Next i

        ' فحص القيم الفريدة
        For i = 1 To 7
            count = 0
            If Not IsEmpty(values(i)) Then
                For j = 1 To 7
                    If CStr(values(j)) = CStr(values(i)) Then
                        count = count + 1
                    End If
                Next j
                ' إذا كانت القيمة فريدة
                If count = 1 Then
                    ' تطبيق التنسيق على الخلية في C:I
                    With ws.Cells(r + startRow - 1, i + 2)
                        .Interior.Color = RGB(255, 255, 0) ' تعبئة صفراء
                        .Font.Color = RGB(255, 0, 0)       ' خط أحمر
                        .Font.Bold = True                   ' خط عريض
                    End With
                    ' تطبيق نفس التنسيق على الخلية في العمود O في نفس الصف
                    With ws.Cells(r + startRow - 1, "O")
                        .Interior.Color = RGB(255, 255, 0) ' تعبئة صفراء
                        .Font.Color = RGB(255, 0, 0)       ' خط أحمر
                        .Font.Bold = True                   ' خط عريض
                    End With
                End If
            End If
        Next i
    Next r

    MsgBox "تمت معالجة البيانات بنجاح!", vbInformation
    Exit Sub

ErrorHandler:
    MsgBox "حدث خطأ: " & Err.Description, vbCritical
End Sub

 

[mahmoud nasr alhasany]

الف شكر ا/  hegazee 

على مساعدته لهذه المشكله