محتاج كود لتلوين الخلايا فى عمود بحيث بياناته غير موجوده فى خلايا العمود الثانى

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

السلام عليكم .. اليكم ملف صغير به عمودين بيتم ملئ خلايا العمود الثانى بييانات هذه البيانات محصورة فى العمود الاول وفى حالة استيفاء بيانات غير موجود بالعمود الاول تلون الخلايا وعند تصحيح البيانات يتم استعادة لون الخلية الاصلى

مع جزيل الشكر

مقارنة بيانات عمود ببيانات عمود اخر.xls

[أ / محمد صالح]

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

أنا شخصيا لا ألجأ إلى الكود إلا في حالة عدم تنفيذ المطلوب بالمعادلات

ولكن لا أدري لماذا حكمت بكون التنسيق الشرطي لن يفيد؟؟

يمكنك تجربة هذه المعادلة في التنسيق الشرطي

=COUNTIF($F$1:$F$9,"="&I1)=0

وتطبق على I1:I100 مثلا أو أي نطاق تريده

ويمكن الحصول على الكود عند تسجيل ماكرو لهذه العملية

والتعديل عليه في تحديد يداية ونهاية النطاق أو المعادلة

بالتوفيق

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

السلام عليكم .. اشكرك على الرد والاهتمام هو بالفعل تم عمل المطلوب بالتنسيق الشرطى ولكن مع كبر البيانات وكثرة الاعمدة اصبح هناك صعوبة بالغة فى ادخال البيانات وتعديلها لبطئ عمل الملف لذلك الجأ إلى الاكواد

تقبل تحياتى 

برجاء برجاء تنفيذ المطلوب بالاكواد

[محمد هشام.]

Private Sub Worksheet_Change(ByVal Target As Range)

  Set a = Range("F2:F" & [F65000].End(xlUp).Row)
  Set b = Range("I2:I" & [I65000].End(xlUp).Row + 10)
  
    Set rng1 = CreateObject("Scripting.Dictionary")
    Set rng2 = CreateObject("Scripting.Dictionary")
    
If Target.Column <> 6 And Target.Column <> 9 Then Exit Sub
For Each J In a
   rng1(J.Value) = J.Value
  Next J

  For Each J In b
    rng2(J.Value) = J.Value

If Not rng1.exists(J.Value) And rng2(J.Value) <> "" Then J.Interior.ColorIndex = 36
If rng1.exists(J.Value) Or rng2(J.Value) = "" Then J.Interior.ColorIndex = xlNone
  Next J
End Sub

 

 

test.xlsb

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

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

وعليكم السلام

ربما

Sub test()
    Dim a
    Dim i&
    a = Range(Cells(2, 6), Cells(2, 6).End(xlDown)).Cells
    With CreateObject("scripting.dictionary")
        For i = 1 To UBound(a)
            If Not .exists(a(i, 1)) Then .Add a(i, 1), a(i, 1)
        Next
        For i = 2 To Cells(Rows.Count, 9).End(xlUp).Row
            If Not .exists((Cells(i, 9).Value)) Then
                Cells(i, 9).Interior.Color = vbRed
            End If
        Next
    End With
End Sub
  أو
Sub tes2()
    Dim a
    Dim i&
    With CreateObject("scripting.dictionary")
        For i = 1 To Cells(Rows.Count, 6).End(xlUp).Row
            If Not .exists(Cells(i, 6).Value) Then .Add Cells(i, 6).Value, ""
        Next
        For i = 2 To Cells(Rows.Count, 9).End(xlUp).Row
            If Not .exists((Cells(i, 9).Value)) Then
                Cells(i, 9).Interior.Color = vbYellow
            End If
        Next
    End With
End Sub

مع المحافظة على لون الخلية عند تغيير القيمة

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

السلام عليكم .. اشكر الاساتذة الافاضل على الحلول 

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

عند تطبيق الكود على الملف لم ينفذ وظهرت المشكلة كما بالصورة

الاستاذ الفاضل / محى الدين

عند تطبيق الكود وتنفيذه على الملف عند تغيير القيم واعادة تنفيذ الكود لا يقوم بالغاء اللون واعادته للون الخلية الاصلى .. كما تم تعديل الكود ووضعة فى حدث الشيت لتنفيذه عند تغيير القيم فلا يتم تعديل التعبئة 

اشكركم على المساعدة وفى انتظار الحلول .. طبتم وطاب يومكم بالصحة والستر والسعادة

 

 

 

 

 

 

 

[محمد هشام.]

يمكنك تحميل المرفق في المشاركة السابقة للتجربة وللعلم  سيتم تمييز القيم في العمود الثاني  الغير موجودة في العمود الأول وعند التصحيح يتم إلغاء اللون  هذا ما فهمت من طلبك. بالتوفيق. 

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

Sub test()
    Dim a
    Dim i&
    a = Range(Cells(2, 6), Cells(2, 6).End(xlDown)).Cells
    With CreateObject("scripting.dictionary")
        For i = 1 To UBound(a)
            If Not .exists(a(i, 1)) Then .Add a(i, 1), a(i, 1)
        Next
        For i = 2 To Cells(Rows.Count, 9).End(xlUp).Row
            If Not .exists((Cells(i, 9).Value)) Then
                Cells(i, 9).Interior.Color = vbRed
            Else
            Cells(i, 9).Interior.Color = xlNone
            End If
        Next
    End With
End Sub
  ---------------------
Sub tes2()
    Dim a
    Dim i&
    With CreateObject("scripting.dictionary")
        For i = 1 To Cells(Rows.Count, 6).End(xlUp).Row
            If Not .exists(Cells(i, 6).Value) Then .Add Cells(i, 6).Value, ""
        Next
        For i = 2 To Cells(Rows.Count, 9).End(xlUp).Row
            If Not .exists((Cells(i, 9).Value)) Then
                Cells(i, 9).Interior.Color = vbYellow
                Else
                Cells(i, 9).Interior.Color = xlNone
            End If
        Next
    End With
End Sub

ماكرو عادي يتم تنفيذه من قبلك

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

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

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

من اعماق قلبى اشكر الاساتذة الافاضل 

محمد هشام 

محى الدين ابو البشر

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

ولو تفضلتم ممكن لاثراء الموضوع تطبيق الحل على عدة اعمدة كما بالمرفق .. مع جزيل الشكر والعرفان

مقارنة بيانات عمود ببيانات عمود اخر (1).xls

[محمد هشام.]

Sub test4()
Dim sh As Worksheet: Set sh = Sheets("Sheet1")
Lr = sh.Columns("I:N").Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row
Set a = Range("F2:F" & [F65000].End(xlUp).Row)
Set b = Range("I2:N" & Lr)

Application.ScreenUpdating = False
  Set R1 = CreateObject("Scripting.Dictionary")
  Set R2 = CreateObject("Scripting.Dictionary")
  
  For Each J In a
   R1(J.Value) = J.Value
   
Next J

  For Each J In b
    R2(J.Value) = J.Value
    
If Not R1.exists(J.Value) And R2(J.Value) <> "" Then J.Interior.ColorIndex = 36
If R1.exists(J.Value) Or R2(J.Value) = "" Then J.Interior.ColorIndex = xlNone

  Next J
End Sub

 

مقارنة بيانات عمود ببيانات عمود اخر 2.xls

او  

Private Sub Worksheet_Change(ByVal Target As Range)

Lr = Columns("I:N").Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row
Set a = Range("F2:F" & [F65000].End(xlUp).Row)
Set b = Range("I2:N" & Lr)

With Target
    Select Case .Column
        Case 6, 9, 10, 11, 12, 13, 14
            If .Row > 1 Then
            
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    
    Set R1 = CreateObject("Scripting.Dictionary")
    Set R2 = CreateObject("Scripting.Dictionary")
  
  For Each j In a: R1(j.Value) = j.Value: Next j
  For Each j In b: R2(j.Value) = j.Value
  
If Not R1.exists(j.Value) And R2(j.Value) <> "" Then j.Interior.ColorIndex = 42
If R1.exists(j.Value) Or R2(j.Value) = "" Then j.Interior.ColorIndex = xlNone
Next j

    Application.EnableEvents = True
    Application.ScreenUpdating = True
   
        End If
    End Select
End With
End Sub

 

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

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

Sub test()
    Dim a, x
    Dim i&, ii&
  Application.ScreenUpdating = False
    a = Range(Cells(2, 6), Cells(2, 6).End(xlDown)).Cells
    With CreateObject("scripting.dictionary")
        For i = 1 To UBound(a)
            If Not .exists(a(i, 1)) Then .Add a(i, 1), a(i, 1)
        Next
        For i = 2 To Cells(1, 9).CurrentRegion.Rows.Count
        For ii = 9 To 9 + Cells(1, 9).CurrentRegion.Columns.Count - 1
            If Not .exists((Cells(i, ii).Value)) Then
                Cells(i, ii).Interior.Color = vbRed
            Else
            Cells(i, ii).Interior.Color = 16777164
            End If
        Next: Next
    End With
    Application.ScreenUpdating = True
End Sub

Sub tes2()
    Dim a, x
    x = Cells(1, 9).CurrentRegion.Columns.Count
    Dim i&, ii&
    Application.ScreenUpdating = False
    With CreateObject("scripting.dictionary")
        For i = 1 To Cells(Rows.Count, 6).End(xlUp).Row
            If Not .exists(Cells(i, 6).Value) Then .Add Cells(i, 6).Value, ""
        Next
        For i = 2 To Cells(1, 9).CurrentRegion.Rows.Count
        For ii = 9 To 9 + Cells(1, 9).CurrentRegion.Columns.Count - 1
            If Not .exists((Cells(i, ii).Value)) Then
                Cells(i, ii).Interior.Color = vbYellow
                Else
                Cells(i, ii).Interior.Color = 16777164
            End If
        Next: Next
    End With
    Application.ScreenUpdating = True
End Sub

 

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

الاساتذة الافاضل 

محمد هشام

محى الدين ابو البشر 

اكرمكم الله بواسع فضله وزادكم من نعمه وفضله

وتسلم يداك اخى العزيز محى مجهود رائع .. تقبل شكرى واعتزازى