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

[محمد ابراهيم78]

السلام عليكم ....

ارجوا ايجد حل لتلوين الخلايا المكررة في نفس الصفحة و الخلايا المكررة في جميغ الصفحات .

مثال :

عند الكتابة في اي  الخلية في العمود C في اي صفحة تقارن في العمود C في الصفحة 1 و 2 و 3 اذا كانت موجودة تلون بلون معين

مع جزيل الشكر ....

تلوين الخلايا المكررة.xlsx

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

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

اليك ملفان

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

الثاني زر امر مع رسالة تحدد التكرار وفي اي صفحة   مع زر امر لمسح اللون الاصفر

تلوين الخلايا المكررة (1).xlsb

تلوين الخلايا المكررة (2).xlsb

 

[محمد ابراهيم78]

السلام عليكم ...

شكرا جزيلا على الرد

ولكن المطلوب اريد اوتماتك عن كتابة اي اسم في العمود C في اي صفحة يغير لون الخلية اذا كان مكرر في الصفحات

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

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

1 ساعه مضت, محمد ابراهيم78 said:

ولكن المطلوب اريد اوتماتك عن كتابة اي اسم في العمود C في اي صفحة يغير لون الخلية اذا كان مكرر في الصفحات

وهذا ما يقوم به الملف فهل جربت الملف الاول ؟

 اكتب اي حرف او اسم في اي صفحة فاذا كات مكررا يتم تلوينه بالاصفر اوتامتيك  تلقائيا

ربما لديك الماكرو غير مفعل

ارفق لك الملف مرة اخرى

تلوين الخلايا المكررة (1).xlsb

 

تم تعديل يناير 8, 2025 بواسطه عبدالله بشير عبدالله

[محمد هشام.]

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

في 8‏/1‏/2025 at 14:56, محمد ابراهيم78 said:

ولكن المطلوب اريد اوتماتك عن كتابة اي اسم في العمود C في اي صفحة يغير لون الخلية اذا كان مكرر في الصفحات

جرب هدا 

في Module  ضع الكود التالي 

Sub ColoriageDoublons()
    Dim WSarr As Variant, couleurs As Long, d As Object, _
    s As Variant, OnRng As Range, lastRow As Long, a, i As Long
    WSarr = Array(1, 2, 3): couleurs = RGB(0, 204, 255)
    Set d = CreateObject("Scripting.Dictionary")

    For Each s In WSarr
        With Sheets(s)
            lastRow = .Cells.Find(What:="*", LookIn:=xlValues, _
            SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
            a = .Range("C4:C" & lastRow).Value
            For i = 1 To UBound(a, 1)
                If a(i, 1) <> "" Then d(a(i, 1)) = d(a(i, 1)) + 1
            Next i
        End With
    Next s

    For Each s In WSarr
        With Sheets(s)
            lastRow = .Cells.Find(What:="*", LookIn:=xlValues, _
            SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
            Set OnRng = .Range("C4:C" & lastRow)
            a = OnRng.Value
            For i = 1 To UBound(a, 1)
                OnRng.Cells(i).Interior.Color = IIf(a(i, 1) <> "" And d(a(i, 1)) > 1, couleurs, xlNone)
            Next i
        End With
    Next s
End Sub

وفي حدث ThisWorkbook

Option Explicit
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
    Dim WSarr As Variant
    WSarr = Array("1", "2", "3")
    If Not Intersect(Target, Sh.Columns("C")) Is Nothing And Target.Row >= 4 Then
        Application.ScreenUpdating = False
        If Not IsError(Application.Match(Sh.Name, WSarr, 0)) Then
            Call ColoriageDoublons
        End If
        Application.ScreenUpdating = True
    End If
End Sub

 

 

 

تلوين الخلايا v2 المكررة.xlsm

[محمد ابراهيم78]

جزيل الشكر ... هو المطلوب شكراً لجهودكم