تبسيط هذا الكود او تعديله

[طارق زكريا حسين جاه الرسول]

بسم الله الرحمن الرحيم 
بعد التحية تعديل الكود.rar
المطلوب ان شاء الله
كود ابسط من ذلك حتى استطيع تنفيذه 
على جميع ايام السنة او على الاقل شهر كامل
ولكم جزيل الشكر والتقدير

 

 

تعديل الكود.rar

[وائل احمد المصري]

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

أخي طارق برجاء الأطلاع على المرفق علة يلبي طلبك

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

Pivot table

المدى المستخدم حتى 15000 صف

تعديل الكود.rar

[طارق زكريا حسين جاه الرسول]

اخى العزيز وائل احمد المصري

احتمال اننى لم استطيع ان اعبر عن سؤالى بالطريقة الصحيحة

اريد مثل الكود الذى بالصفحة ولاكن بطريقة بسيطة (لانه كل يوم يحتاج الى عدد عشرة سطور كود)

لكم الشكر والعرفان

[الـعيدروس]

السلام عليكم

الاخ الفاضل زكريا

اضفنا الجداول كنطاق واحد واسميته  My_Nem 

وعند عمل جدول ليوم جديد حدث النطاق ليستوعب الجدول الجديد وهكذا

اطلع على المرفق 

تعديل الكود1.rar

[طارق زكريا حسين جاه الرسول]

استاذى العزيز

الـعيدروس

بعد التحية

عفوا سيدى لم افهم الشرح

[الـعيدروس]

عذراً ماعملته لاينفذ ماتريد في المرفق السابق

ماهو شرط الكود هل اذا تاريخ خليه C1 لايطابق الخليه الحاليه لايسمح بالتعديل ؟

[طارق زكريا حسين جاه الرسول]

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

كل جدول له تاريخ اريد التعدل فى الجدول الذى به تاريخ الكمبيوترفقط ولايسمح بتعديل داخل اى جدول به تاريخ اخر

ولك جزيل الشكر والتقدير مرفق الملف تعديل الكود.rar

تعديل الكود.rar

[الـعيدروس]

هذا حل اول

استبدل الكود التالي بالذي في حدث الورقة ف الملف

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim Rng As Range, Rng1 As Range
Dim Lis
For Each Lis In ThisWorkbook.Names
Set Rng = Range(Lis)
If Not Application.Intersect(Target, Rng) Is Nothing Then
    If Cells(Rng.Cells(1, 1).Row - 1, Rng.Cells(1, 2).Column) <> CVDate(Date) Then
     Application.EnableEvents = False
           Target.Offset(, -1).Select
           Application.EnableEvents = True
           MsgBox "عفواً... ليس لديكم الصلاحية لتعديل البيانات"
           Exit For
           Else
           Exit Sub
       End If
   End If
Next
End Sub

 

بشرط كل جدول تحط له اسم جديد

 جزء من الجدول كما الصوره تحط له اسم 

عند ادراج جدول ليوم جديد  تروح تحدد كما موضح بالصورة وتحفظه بمسمى 

الى ان اتوصل الى حل افضل سوف ارفقه هنا 

 

[طارق زكريا حسين جاه الرسول]

منتظر من سادتكم الافضل

[الـعيدروس]

او هكذا هذا افضل تعديل

 

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim Rng As Range, Rng1 As Range
For Each Rng In Range("TAREK").Areas
If Not Application.Intersect(Target, Rng) Is Nothing Then
    If Cells(Rng.Cells(1, 1).Row - 1, Rng.Cells(1, 2).Column) <> CVDate(Date) Then
     Application.EnableEvents = False
           Target.Offset(, -1).Select
           Application.EnableEvents = True
           MsgBox "عفواً... ليس لديكم الصلاحية لتعديل البيانات"
           Exit For
           Else
           Exit Sub
       End If
   End If
Next
End Sub

الكود يعتمد على المدى المسمى TAREK الموجود لديك ضمن الملف

 

[مختار حسين محمود]

بارك الله فيك أستاذنا الفاضل العيدروس

بعد تجربة الكود فى صورنه الأخيرة وجدت أنه يمكن التعديل فى البيانات اذا كان التاريخ  لا يساوى تاريخ اليوم

فمثلا اذا كان التاريخ  13 /10 /2015  وهو لا يساوى تاريخ اليوم 14/10/2015  فيمكن التعديل فى المبلغ بأن تقف فى الخلية التى تليها وحاول تعديلها

ستجد أن الكود انتقل بك الى خلية المبلغ  عندها عدّل المبلغ ستجد أنه تم تعديله والانتقال الى خلية المسلسل

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

Private Sub Worksheet_Change(ByVal Target As Range)
Dim Rng As Range
For Each Rng In Range("TAREK").Areas
    If Not Application.Intersect(Target, Rng) Is Nothing Then
             If Cells(Rng.Cells(1, 1).Row - 1, Rng.Cells(1, 2).Column) <> CVDate(Date) Then
                  Application.EnableEvents = False
                  Application.Undo
                  Application.EnableEvents = True
                  MsgBox "عفواً... ليس لديكم الصلاحية لتعديل البيانات"
             Else
                 Exit Sub
             End If
     End If
Next
End Sub

تحياتى للجميع

 

[الـعيدروس]

الاخ الفاضل مختار حسين مشكور على الملاحظه والتعديل  

 

 

[طارق زكريا حسين جاه الرسول]

الاخ الفاضل مختار حسين

انه حل فى منتهى الجمال

اولا اشكر الاستاذ العيدروس

واشكر كم جميعا