تظليل الاسماء المرتبطة عند ترحيلها تلقائيا

[أبو إيمان]

السلام عليكم 

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

ثانيا :  المطلوب في ورقة كشف الترحيل SHEET2

 

تظليل الاشخاص المرتبطين.xlsm

[lionheart]

Insert module and paste the following code

Sub Highlight_Names_In_Similar_Groups()
    Dim groupColors(), ws As Worksheet, sh As Worksheet, colRange As Range, cell As Range, sName As String, lr As Long, i As Long
    Application.ScreenUpdating = False
        Set ws = ThisWorkbook.Worksheets(2)
        Set sh = ThisWorkbook.Worksheets(3)
        Set colRange = ws.Range("E12:N20")
        lr = sh.Cells(sh.Rows.Count, 3).End(xlUp).Row
        groupColors = RandomColors(colRange.Columns.Count, True)
        sh.Columns("C:F").Interior.Color = xlNone
        For Each cell In colRange.Cells
            sName = Trim(cell.Value)
            If sName <> Empty Then
                For i = 3 To lr
                    If Trim(sh.Cells(i, 3).Value) = sName And sh.Cells(i, 3).Interior.Color <> xlNone Then
                        sh.Cells(i, 4).Resize(, 3).Interior.Color = groupColors(cell.Column - 4)
                    End If
                Next i
            End If
        Next cell
    Application.ScreenUpdating = True
End Sub

Function RandomColors(ByVal numColors As Long, Optional ByVal lightColorsOnly As Boolean = False)
    Dim isUnique As Boolean, i As Long, j As Long
    ReDim colors(1 To numColors)
    For i = 1 To numColors
        Do
            If lightColorsOnly Then
                colors(i) = RGB(Int(Rnd() * 128) + 128, Int(Rnd() * 128) + 128, Int(Rnd() * 128) + 128)
            Else
                colors(i) = RGB(Int(Rnd() * 256), Int(Rnd() * 256), Int(Rnd() * 256))
            End If
            isUnique = True
            For j = 1 To i - 1
                If colors(i) = colors(j) Then isUnique = False: Exit For
            Next j
        Loop Until isUnique
    Next i
    RandomColors = colors
End Function

 

 Then in worksheet module of the first worksheet add this part at the end of the existing code

        Next c
    End If
    If Target.Address = "$C$2" Then Call Highlight_Names_In_Similar_Groups
End Sub

 

[أبو إيمان]

شكرا لك أستاذ Lionheart

الكود جميل والفكرة ممتازة وفكرة الألوان العشوائية تعطي احساس بالتجديد 

عندى ملاحظة بسيطة

أنه عند التجهيز  يتم كتابة الرقم في الخلية C2  قبل كتابته أمام الأفراد  والكود لايعمل إلا اذا تم كتابة الرقم بعد الاختيار

وسوف اتغلب على هذه الجزئية بوضع استدعاء الكود داخل  كود أخر مخصص للطباعة 

 

تقبل تحياتي وشكراً لك