اضافة قيمة في خلية بناء على قيم خلايا أخرى

[أبو إيمان]

السلام عليكم 

لدي ملف يحتوى على عدد من الاشخاص وفي كل يوم يتم حضور ما يقرب من 70 شخص لغرض ما وهناك بعض الاشخاص الذين يتوجب حضورهم في نفس اليوم  مثلا

رقم 101 و 108 و 110

رقم 102 و 106

 

المطلوب كود عند كتابة رقم اليوم أمام 101 يتم كتابته تلقائيا أما الاشخاص المرتبطين به

وكذلك 102  

 

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

[lionheart]

In worksheet module try

Private Sub Worksheet_Change(ByVal Target As Range)
    Const SROW As Long = 6, EROW As Long = 12, SCOL As Long = 3, ECOL As Long = 6
    Dim x, v, rng As Range, cel As Range, c As Long
    If Target.Column = 3 And Target.Row > 15 Then
        For c = SCOL To ECOL
            With Sheets(2)
                Set rng = .Range(.Cells(SROW, c), .Cells(EROW, c))
                x = Application.Match(Target.Offset(, 1).Value, rng, 0)
                If Not IsError(x) Then
                    For Each cel In rng
                        If Not IsEmpty(cel) Then
                            v = Application.Match(Val(cel.Value), Columns(Target.Offset(, 1).Column), 0)
                            If Not IsError(v) Then
                                Application.EnableEvents = False
                                    Cells(v, Target.Column).Value = Target.Value
                                Application.EnableEvents = True
                            End If
                        End If
                    Next cel
                End If
            End With
        Next c
    End If
End Sub

 

[أبو إيمان]

جزاكم الله خيرا وسلمت يمينك

[أبو إيمان]

السلام عليكم 

الاخ lionheart

هل يمكن التعديل في الكود المرفق بحيث أن رقم ( كود الشخص ) يحتوي على حروف 

 

 

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

[lionheart]

Try changing this line and remove Val function

v = Application.Match(Val(cel.Value), Columns(Target.Offset(, 1).Column), 0)

To be

v = Application.Match(cel.Value, Columns(Target.Offset(, 1).Column), 0)

 

[أبو إيمان]

جاري التجربة 

 

هل يمكن أن يتم تظليل الأسماء المرتبطة  في كشف الترحيل كل مجموعة بلون مختلف

 

 

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

[أبو إيمان]

منذ ساعه, lionheart said:

v = Application.Match(cel.Value, Columns(Target.Offset(, 1).Column), 0)

 

 

الاستاذ / lionheart

شكرا جزيلا يعمل بكفاءة

 

باقي التظليل

[lionheart]

Try the code and if you have any different request please post a new topic

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    Const SROW As Long = 6, EROW As Long = 20, SCOL As Long = 5, ECOL As Long = 8
    Dim x, v, rng As Range, cel As Range, c As Long, n As Long
    If Target.Column = 3 And Target.Row > 15 Then
        For c = SCOL To ECOL
            n = 0
            If c = 5 Then
                n = RGB(125, 219, 210)
            ElseIf c = 6 Then
                n = RGB(255, 218, 100)
            ElseIf c = 7 Then
                n = RGB(155, 200, 95)
            ElseIf c = 8 Then
                n = RGB(85, 116, 123)
            End If
            With Sheet2
                Set rng = .Range(.Cells(SROW, c), .Cells(EROW, c))
                x = Application.Match(Target.Offset(, 1).Value, rng, 0)
                If Not IsError(x) Then
                    For Each cel In rng
                        If Not IsEmpty(cel) Then
                            v = Application.Match(cel.Value, Columns(Target.Offset(, 1).Column), 0)
                            If Not IsError(v) Then
                                Application.EnableEvents = False
                                    Cells(v, Target.Column).Value = Target.Value
                                    Cells(v, Target.Column).Interior.Color = n
                                Application.EnableEvents = True
                            End If
                        End If
                    Next cel
                'Exit For
                End If
            End With
        Next c
    End If
End Sub

 

[أبو إيمان]

الاستاذ   lionheart

 

* أولا : شكرا للتوضيح وسوف يتم العمل بهذه النصيحة

* ثانيا : الكود يعمل بكفاءة  لكن يعمل عن نفس الورقة المسماة  الرئيسي  والمطلوب أن يتم التظليل في ورقة العمل المسماة كشف الترحيل مع ملاحظة ازالة اللون إذا تم ازالة رقم اليوم من أمام كود الشخص       في ورقة العمل  المسماة الرئيسي

21 ساعات مضت, أبو إيمان said:

تظليل الأسماء المرتبطة  في كشف الترحيل كل مجموعة بلون مختلف

 

[lionheart]

I have no idea about the new request. Please post a new topic with all the required details

[أبو إيمان]

شكرا لك أخي الكريم  lionheart

وتم إضافة مووضوع جديد بالمطلوب الجديد في الرابط

https://www.officena.net/ib/topic/118797-تظليل-الاسماء-المرتبطة-عند-ترحيلها-تلقائيا/