كود اذا حصل تغيير في شيت يذهب التغيير الى شيت اخر حسب الاسم

[صباح2024]

السلام عليكم

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

اذا حصل تغيير - يذهب التغيير الى السجل على اساس الأسم.xlsm

[محمد هشام.]

هل المطلوب تحديث البيانات عند التغيير في الخلايا ذات اللون  الأصفر أو الأزرق ممكن توضح أكثر  

 

[محمد هشام.]

جرب وضع هدا في Module

Option Explicit
Sub TestUpdate()
    Dim dest As Worksheet, WS As Worksheet
    Dim Clé As String, i As Integer
    Dim tmp As Range, cnt As Variant
    Dim Irow As Long, ColArr As Variant, rng As Range
    
    Set WS = Sheets("استدعاء")
    Set dest = Sheets("السجل")
    
    Clé = WS.Range("B8").Value
    If Clé = "" Then Exit Sub
    
    Set rng = dest.Range("B2:B" & dest.Cells(dest.Rows.Count, 2).End(xlUp).Row)
    Set tmp = rng.Find(Clé, LookIn:=xlValues, lookat:=xlWhole)

    
    If tmp Is Nothing Then
        MsgBox "لم يتم العثور على الإسم في السجل", vbExclamation
        Exit Sub
    End If

    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    Irow = tmp.Row
    
    ColArr = Array(8, 9, 10, 14, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29)

    cnt = Array(WS.Range("A12").Value, WS.Range("B12").Value, WS.Range("C12").Value, _
                WS.Range("D12").Value, WS.Range("E12").Value, WS.Range("F12").Value, _
                WS.Range("G12").Value, WS.Range("H12").Value, WS.Range("A15").Value, _
                WS.Range("B15").Value, WS.Range("C15").Value, WS.Range("D15").Value, _
                WS.Range("E15").Value, WS.Range("F15").Value, WS.Range("G15").Value, WS.Range("H15").Value)

    For i = LBound(ColArr) To UBound(ColArr)
        If dest.Cells(Irow, ColArr(i)).Value <> cnt(i) Then
           dest.Cells(Irow, ColArr(i)).Value = cnt(i)
        End If
    Next i
    
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
End Sub

وفي حدث ورقة استدعاء

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Clé As String, cntArr As Range
    Set cntArr = Me.Range("A12:H12,A15:B15")
    If Not Intersect(Target, cntArr) Is Nothing Then
        Call TestUpdate
    End If
End Sub

 

اذا حصل تغيير - يذهب التغيير الى السجل على اساس الأسم.xlsm

تم تعديل أكتوبر 13 بواسطه محمد هشام.

[صباح2024]

السلام عليكم -  اشكرك على الاهتمام والرد

الكود يحتاج الى بعض التعديلات

اني استخدمت كود استدعاء بيانات من اعداد الخبير عبدالله بشير ( بدل المعادلات) لانه المعادلات لا تشتغل ويا الكود

اصبح طلبي - من الاخوة الكرام وخاصة الأخ (محمد هشام ) 

أي تغيير في أي خلية باللون الاصفر يذهب هذا التغيير الى الخانة اللي حصل بها تغيير

فمثلاً اذا غيرت في شيت استدعاء ( القسم : الحسابات ) وغيرته الى ( القسم : الانتاج) يذهب هذا التغيير من الحسابات الى الانتاج في شيت السجل وكذلك باقي الخانات

على الاسم

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

 

تحويل التغييرات من شيت الاستدعاء الى شيت السجل.xlsm

تم تعديل أكتوبر 13 بواسطه صباح2024

[محمد هشام.]

أخي @صباح2024  إدا كنت قد إستوعبت طلبك  سنقوم بتعديل الكود بطريقة مختلفة لنتمكن من تنفيد المطلوب بشكل دقيق لان دمج الاكواد على

 Private Sub Worksheet_Change(ByVal Target As Range)  والإشتغال عليها مباشرة من شأنه أن يسبب لك عدة مشاكل خاصة انك ترغب بتحديث البيانات عند كل تغيير على اي خلية لنفترض أنك قمت باسـتدعاء اي اسم مثلا من الطبيعي ان البيانات السابقة  مختلفة بمجرد استدعائها سيتم نسخها للاعمدة الخاصة بالاسم الدي تم اختياره مما سيسبب لك تلف وتعارض في البيانات 

 اسف على الإطالة لاكن لابد من توضيح الفكرة ( اليك ما تم الإشتغال عليه)

1) جلب البيانات من ورقة السجل الى ورقة استدعاء بشرط الإسم 

2) تحديث البيانات عند التغيير في أي خلية من الخلايا التي تم تمييزها باللون الأصفر على ورقة استدعاء على الأعمدة المناسبة في ورقة السجل  مع مراعات الإسم  

3) تم اظافة كود لإنشاء قائمة  منسدلة ديناميكية  بالأسماء الفريدة  من العمود B ( ورقة السجل)  بداية  من الصف 2 تلقائيا  في خلية الإسم (B6) ورقة استدعاء 

الأكواد المستخدمة :

Public Property Get WS() As Worksheet
    Set WS = Sheets("استدعاء")
End Property

Public Property Get dest() As Worksheet
    Set dest = Sheets("السجل")
End Property
' خلية الإسم
Public Function Clé() As String
    Clé = WS.Range("B6").Value
End Function
'نطاق البحث
Public Function rng() As Range
    Set rng = dest.Range("B2:B" & dest.Cells(dest.Rows.Count, 2).End(xlUp).Row)
End Function
'========================
' جلب البيانات من ورقة السجل إلى ورقة "استدعاء"
Sub Fetch_data()

    Dim data As Variant, i As Long, tmp As Range
    Application.ScreenUpdating = False
    On Error GoTo CleanExit
    Set tmp = rng.Find(Clé, LookIn:=xlValues, LookAt:=xlWhole)

    If tmp Is Nothing Then
        MsgBox "لم يتم العثور على الإسم" & " : " & Clé & " في السجل", vbExclamation
        Exit Sub
    End If
    
    For i = 0 To 3
        data = dest.Range(tmp.Offset(0, 1 + (i * 9)), tmp.Offset(0, 9 + (i * 9))).Value
        WS.Range("A" & (9 + (i * 3)) & ":I" & (9 + (i * 3))).Value = data
    Next i

CleanExit:
    Application.ScreenUpdating = True
End Sub
'========================
' تحديث البيانات من ورقة استدعاء الى ورقة السجل
Sub Update_data()
    Dim tmp As Range, cnt() As Variant, OnRng As Range
    Dim ColArr() As Long, j As Long, i As Long

    Set OnRng = rng.Find(Clé, LookIn:=xlValues, LookAt:=xlWhole)

    If OnRng Is Nothing Then
        MsgBox "لم يتم العثور على الإسم" & " : " & Clé & " في السجل", vbExclamation
        Exit Sub
    End If

    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

    Dim Irow As Long
    Irow = OnRng.Row
    ReDim ColArr(0 To 35)
    For j = 0 To 35
        ColArr(j) = j + 3
    Next j

    ReDim cnt(UBound(ColArr))
    For i = 0 To UBound(cnt)
        cnt(i) = WS.Cells(9 + (i \ 9) * 3, 1 + (i Mod 9)).Value
    Next i

    For i = 0 To UBound(ColArr)
        If dest.Cells(Irow, ColArr(i)).Value <> cnt(i) Then
            dest.Cells(Irow, ColArr(i)).Value = cnt(i)
        End If
    Next i

    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
End Sub
'========================
' إضافة قائمة منسدلة بالأسماء المتوفرة في ورقة "السجل"
Sub Add_listeDéroulante()

    Dim lr As Long, arr() As String, r As Range, i As Long
    Dim cnt As New Collection, Names As Range

    lr = dest.Cells(dest.Rows.Count, 2).End(xlUp).Row
    On Error Resume Next
    For Each r In rng
        If r.Value <> "" Then
            cnt.Add r.Value, CStr(r.Value)
        End If
    Next r
    On Error GoTo 0

    If cnt.Count = 0 Then Exit Sub
    
    ReDim arr(1 To cnt.Count)
    For i = 1 To cnt.Count
        arr(i) = cnt(i)
    Next i

    Set Names = WS.Range("B6")
    With Names.Validation
        .Delete
        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
            xlBetween, Formula1:=Join(arr, ",")
        .IgnoreBlank = True: .InCellDropdown = True: .ShowInput = True: .ShowError = True
    End With
End Sub

وفي حدث ورقة استدعاء 

Private Sub Worksheet_Activate()
    Add_listeDéroulante
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Clé As Range, cntArr As Range
    Set Clé = WS.Range("B6")
 
    If Clé.Value = "" Then Exit Sub

    If Target.Address = Clé.Address Then
        On Error GoTo ErrorHandler
        Fetch_data
        Exit Sub
    End If
   '  عناوين الخلايا المستهدفة 
    Set cntArr = Me.Range("A9:I9, A12:I12, A15:I15, A18:I18")
    If Not Intersect(Target, cntArr) Is Nothing Then
        On Error GoTo ErrorHandler
       Update_data
        Exit Sub
    End If

Exit Sub

ErrorHandler:
    MsgBox "حدث خطأ: " & Err.Description
    On Error GoTo 0
End Sub

وأي إستفسار سنكون دائما سعداء بمساعدتك  

 

تحويل التغييرات من شيت الاستدعاء الى شيت السجل.xlsm

تم تعديل أكتوبر 14 بواسطه محمد هشام.

[صباح2024]

السلام عليكم - أهل العلم والخبرة - اضافة الى علمهم - تواضعهم واهتمامهم بمساعدة الاخرين

وكلمتك

واي إستفسار سنكون دائما سعداء بمساعدتك 

والله هذه الكلمات اسعدني - كما سعدتني بالحل والكود الرائع الذي هو المطلوب

جزاك الله خير