منع الادخال في خلايا عمود او اكثر بناء علي قيمة خلايا عمود آخر

[حمادة عمر]

السلام عليكم

ما اطلبه هو انه كمثال

اذا كانت الخلية A1 مثلا فارغة فعند الادخال في الخلية B1 ، C1 ، D1...... تظهر رسالة تفيد بانه يجب الادخال في الخلية A1 اولا ولايمكن الادخال الا بعد ادخال قيمة في الخلية A1

ثم A2 ــــــــــــ B2 ، C2 ، D2

ثم A3 ــــــــــــ B3 ، C3 ، D3

ويكون ذلك في حدود آخر صف في الشيت أو حتي الصف 2500 مثلا

ارجو ان اكون وفقت في ايصال المعلومة

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

[حمادة عمر]

للرفع

[حمادة عمر]

السلام عليكم

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

ليتناسب مع طلبي ولكني قمت بتنفيذه علي صف واحد فقط وما اريده هو ان يتم تنفيذه علي باقي الصفوف في الشيت حتي 2000 صف مثلاً

Private Sub Worksheet_Change(ByVal Target As Range)

If Me.[a2] <> "" Then Exit Sub

If Not Application.Intersect(Target, Range("b2:c2")) Is Nothing Then

	 Application.EnableEvents = False

	 Application.Undo

	 Application.EnableEvents = True

MsgBox "لايمكنك الادخال هنا .. قبل الادخال في الخلية الرئيسية للصف"

End If

End Sub

Book1.rar

[الـعيدروس]

السلام عليكم

الكود في حدث الورقة

Private Const Msg As String = "أولا إدخال البيانات في عمود A"

Private Const Til As String = "تنبية "

Private Sub Worksheet_Change(ByVal Target As Range)

If Not Intersect(Target, [B:B]) Is Nothing Then If Target.Offset(0, -1) = "" Then MsgBox Msg, vbExclamation, Til: Exit Sub

If Not Intersect(Target, [C:C]) Is Nothing Then If Target.Offset(0, -2) = "" Then MsgBox Msg, vbExclamation, Til: Exit Sub

If Not Intersect(Target, [D:D]) Is Nothing Then If Target.Offset(0, -3) = "" Then MsgBox Msg, vbExclamation, Til: Exit Sub

End Sub

[حمادة عمر]

السلام عليكم

استاذي الفاضل

الكود يعمل كما اريد وعلي المدي المطلوب تماما

ولكن لي طلب به وهو

انه بعد الادخال وخلايا العمود A فارغة فعلا يعطيني رسالة تنبيه بأنه يجب الادخال اولا ولكنه يبقي علي القيمة التي تم وضعها في هذه الخلية

كل ما اريده اضافة جزء مع الكود يمنع او يمسح ما تم ادخاله بالخلايا في العمود B او C أو D بعد رسالة التنبيه مباشرة

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

[الـعيدروس]

جرب هكذا

Private Const Msg As String = "أولا إدخال البيانات في عمود A"

Private Const Til As String = "تنبية "

Private Sub Worksheet_Change(ByVal T As Excel.Range)

With Application

    .EnableEvents = False

If Not Intersect(T, [B:B]) Is Nothing Then If T.Offset(0, -1) = "" Then MsgBox Msg, vbExclamation, Til: T.Clear: Exit Sub

If Not Intersect(T, [C:C]) Is Nothing Then If T.Offset(0, -2) = "" Then MsgBox Msg, vbExclamation, Til: T.Clear: Exit Sub

If Not Intersect(T, [D:D]) Is Nothing Then If T.Offset(0, -3) = "" Then MsgBox Msg, vbExclamation, Til: T.Clear: Exit Sub

    .EnableEvents = True

End With

End Sub

[حمادة عمر]

السلام عليكم

استاذي الفاضل

الكود عمل معي مرة واحدة فقط ولم يعمل بعد ذلك

فسؤالي لسيادتك وكما تعلم انه ليس اول كود لا يعمل معي هل اقوم بتغيير نسخة الاوفيس ام نسخة الجهاز من الاساس

آسف وشاكر لسيادتكم تعبك معنا

اعذرنا فنحن نتعلم منكم .... وجزاك الله خير استاذي الفاضل الكريم