مساعدة في تعديل كود جمع القيمة المدخلة للخلية الى قيمتها السابقة

[خالد القدس2]

أساتذتي الأجلاء الكرام 

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

ارجو المساعدة لتعديل كود جمع قيمة الادخال للخلية إلى قيمتها السابقة قبل الادخال  

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

مرفق ملف للتوضيح  

 

جمع الخلية لنفسها.xlsm

[أبوعيد]

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

تفضل

جمع الخلية.xlsm

[خالد القدس2]

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

[خالد القدس2]

استاذي الجليل أبو عيد  
الكود يعمل مية المية ولكن عندما حاولت توسيع نطاق الخلايا ليشمل (A1:P40) 

وايضا لو تكرمت أريد ربط عمل الكود بزر خيار  أن كان مفعل يعمل وان لم يكن مفعل لا يعمل  

جمع الخلية2.xlsm

[خالد القدس2]

الاساتذة الاجلاء  بالاستعانة بكود الاستاذ أبو عيد مع الذكاء الاصطناعي  تحصلت على الكود التالي  ولكن احيانا لا يعمل  الكود وايضا قد استعان الذكاء الاصطناعي باعمدة أخرى مماثلة لعدد الاعمدة المستهدفة   

ارجو لو امكن اختصار الكود  وجعله مثل كود استاذنا ابو عيد     فالذكاء البشرى أوعى وأفهم من الاصطناعي   وجزاكم الله خيرا 

‏‏جمع الخلية3.xlsm

[أبوعيد]

لا أدري ما تقصد

فتحت ملفك ووجدت خلايا بالأزرق وخلايا بالأحمر

الكود يعمل في الأزرق ولا يعمل في الأحمر

أرجو التوضيح أكثر

[محمد هشام.]

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

جرب هل هدا ما تقصده 

Option Explicit
Dim tmps As Object, cell As Range
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    On Error GoTo ClearApp
    If Target Is Nothing Then Exit Sub
    With Me.Shapes("CheckBox1").ControlFormat
        If .Value = xlOff Then Exit Sub
    End With
    If tmps Is Nothing Then Set tmps = CreateObject("Scripting.Dictionary")
    If Target.Cells.Count > 1 Then Exit Sub
    For Each cell In Target
        If Not Intersect(cell, Me.Range("A1:P40")) Is Nothing Then tmps(cell.Address) = cell.Value
    Next cell
ExitHandler:
    Exit Sub
ClearApp:
    Set tmps = Nothing
Resume ExitHandler
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
    On Error GoTo ClearApp
    If Target Is Nothing Or tmps Is Nothing Then Exit Sub
    With Me.Shapes("CheckBox1").ControlFormat
        If .Value = xlOff Then Exit Sub
    End With
    If Target.Cells.Count > 1 Then Exit Sub
    Application.EnableEvents = False
    For Each cell In Target
        If Not Intersect(cell, Me.Range("A1:P40")) Is Nothing And tmps.exists(cell.Address) Then
            If IsNumeric(cell.Value) Then
                cell.Value = tmps(cell.Address) + cell.Value
            Else
                MsgBox cell.Address & " : " & "تم إدخال قيمة غير صالحة في الخلية ", vbExclamation
            End If
        End If
    Next cell
ExitHandler:
    Application.EnableEvents = True
    Exit Sub
ClearApp:
    Resume ExitHandler
End Sub

 

جمع الخلية v3.xlsb

[خالد القدس2]

مساء الخير  استاذ أبو عيد

المطلوب اساسا ان يعمل الكود على الخلايا باللون الازرق   A1:P40    

ولكن الذكاء الاصطناعي لم يستطع تخزين قيم الخلايا قبل الادخال إلا في خلايا موازيه   Q1:AF40  

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

أما في حالة ازالة التفعيل من  CheckBox1   فان الخلايا الموازية تكون محتفظة بالقيمة القديمة ولا تتغير مع اي ادخال في الخلايا المستهدفة وهكذا عندما تعود لتفعيل  CheckBox1  يحدث خطأ كبير حيث يتم جمع القيمة المدخلة للخلية مع قيمة الخلية الموازية القديمة جدا  حيث لم يقوم بتحديث القيم بعد ازالة تفعيل CheckBox1   

 

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

او الافضل من ذلك لو  كود حضرتك الاول يستطيع ان يشمل النطاق المطلوب مع زر CheckBox1

 

أكون ممنون وشاكر  وفقك الله لكل خير  

[خالد القدس2]

بالتأكيد هذا هو المطلوب بالضبط   ...    وبدون خلايا مساعدة   راااااااااائع   

بارك الله فيك أستاذ محمد هشام  ونفع بك العباد والبلاد من مشرقها الى مغربها  

[خالد القدس2]

كود ابداعي فاخر من الاخر  فاق الذكاء الاصطناعي بمراحل  

ما لقيت فيهو أي ثغرة ما شاء الله تبارك الله  

ألف شكر استاذي محمد هشام  وجزاك الله خيرا