تظليل المتشابه

[waledms]

الأخوه الأفاضل .... السلام عليكم ورحمه الله وبركاته

الملف المرفق يه أسماء لطلبه ( فى عمودين C  و N ) أريد تظليل المتشابه من الأسماء  فى العمود( C )المحتوى على عدد أكبر من الأسماء بحيث يكتفى بأن يكون التشابه فى الأسماء ثلاثياً على الأقل ولا يشترط تطابق الأسماء رباعياً....  

الصف الخامس.xlsx

[lionheart]

Sub Test()
    Dim r As Range, c As Range, s As String
    Application.ScreenUpdating = False
        With ActiveSheet.UsedRange
            .Columns(3).Interior.Color = xlNone
            .Columns(14).Interior.Color = xlNone
            For Each c In .Columns(14).Cells
                If c.Value = "" Then GoTo iNext
                With .Columns(3)
                    Set r = .Find(c.Value, , xlValues, xlPart)
                    If Not r Is Nothing Then
                        s = r.Address
                        Do
                            r.Interior.Color = vbYellow
                            c.Interior.Color = vbRed
                            Set r = .Find(c.Value, , xlValues, xlPart)
                        Loop Until r.Address = s
                        Set r = Nothing
                    End If
                End With
iNext:
            Next c
        End With
    Application.ScreenUpdating = True
End Sub

 

[waledms]

بعد إذن حضرتك ..... أين أضع هذا الكود لكى يعمل

[lionheart]

 Press Alt + F11 when you are in the worksheet then from Insert menu in the VBE select module and at last paste the code

To run the code press Alt  F8 while you are in the worksheet and select the macro named Test and finally click Run

 

I think it is better to learn the VBA basics first before posting questions

[waledms]

السلام عليكم ورحمه الله وبركاته ..... أولا هناك أسماء مكررة فى العمودين وغير مظلله .... ثانيا يكفى التظليل للأسماء المكرره فى العمود C فقط ويبقى العمود N بدون تظليل ويكفى أن يكون التشابه فى الأسماء ثلاثيا فقط ليتم التظليل ... معذرة للإطاله

الصف الخامس.xlsx

[lionheart]

Give me examples of the uncolored rows

[waledms]

N8 - N21 - N22 - N50 - N57 - ولو أمكن يكون التظليل فى عمود الأسماء C فقط 

[lionheart]

The question is not logical as there are many difference in the inputs in the two columns

That's my try but of course not the perfect solution

Sub Test()
    Dim e, x, r As Range, c As Range, s As String, v As String, t As String, b As String, d As String, f As String
    Application.ScreenUpdating = False
        With ActiveSheet.UsedRange
            .Columns(3).Interior.Color = xlNone
            .Columns(14).Interior.Color = xlNone
            For Each c In .Columns(14).Cells
                If c.Value = "" Then GoTo iNext
                b = Replace(c.Value, Chr(218) & Chr(200) & Chr(207) & Chr(32) & Chr(199), Chr(218) & Chr(200) & Chr(207) & Chr(199))
                x = Split(b)
                d = x(0) & Space(1) & x(1) & Space(1) & x(2)
                b = Replace(c.Value, Chr(236), Chr(237))
                x = Split(b)
                f = x(0) & Space(1) & x(1) & Space(1) & x(2)
                x = Split(c.Value)
                v = x(0) & Space(1) & x(1) & Space(1) & x(2)
                t = Replace(v, Chr(201), Chr(229))
                With .Columns(3)
                    For Each e In Array(t, v, d, f)
                        Set r = .Find(e, , xlValues, xlPart)
                        If Not r Is Nothing Then
                            s = r.Address
                            Do
                                r.Interior.Color = vbYellow
                                Rem c.Interior.Color = vbRed
                                Set r = .Find(e, , xlValues, xlPart)
                            Loop Until r.Address = s
                            Set r = Nothing
                        End If
                    Next e
                End With
iNext:
            Next c
        End With
    Application.ScreenUpdating = True
End Sub

 

[waledms]

God reward you

جزاك الله خيرا