تعديل على الكود حتى يتوقف ويخرج عند تحقق شرط معين

[gamalin2]

في الملف المرفق 

يوجد شيت po_rec و شيت recept

مطلوب ..عند تحقق شرط وهو وجود كلمة recept1  .... الى recept6 في عمود 13 وايض بشرط الايكون في عمود 14 يوجد كلمة ok  

يتم نقل بعض البيانات الى شيت recept كتابة ok  .. ف نفس السطر في شيت po_rec , والخروج من الدورة لحين طلب التنفيذ مرة اخرى 

عنوان مخالف ... تـــم تعديل عنوان المشاركة ليعبر عن طلبك ... وطالما ان حجم الملف صغير فممنوع رفعه مضغوط .. فقد تم اعادة رفع الملف بدون ضغط مع امتداد يقبل لصق الأكواد به وهو XLSM

Sub recp_fill()

On Error Resume Next
Application.ScreenUpdating = False
 For a = 5 To [a10000].End(xlUp).Row
    If Cells(a, 2) <> "" And Cells(a, 13) = "recept1" Or Cells(a, 13) = "recept2" Or Cells(a, 13) = "recept3" Or Cells(a, 13) = "recept4" Or Cells(a, 13) = "recept5" Or Cells(a, 13) = "recept6" And Cells(a, 14) <> "ok " Then
    
       MySheets = "recept"
         With Sheets(MySheets).[a10000].End(xlUp)
      
              .Offset(4 - 21, 1) = Cells(a, 2)
              .Offset(6 - 21, 1) = Cells(a, 5)
              .Offset(7 - 21, 1) = Cells(a, 6)
              .Offset(8 - 21, 1) = Cells(a, 😎
              .Offset(21 - 21, 1) = Cells(a, 13)
         End With
     End If
         Sheets("po_rec").Cells(a, 14).Value = "ok"
  Next a
Application.ScreenUpdating = True
MsgBox "!تم الترحيل   بنجاح", vbInformation + vbMsgBoxRight, "تم الترحيل"
Range("b6").Select
On Error GoTo 0
End Sub

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

refill.xlsm

[أ / محمد صالح]

أخي الكريم

بعض الملاحظات على الكود المعروض من حضرتك:

* هذا السطر يقوم بكتابة ok في العمود 14 في كل صف سواء تحقق الشرط أو لم يتحقق لأن هذا السطر بعد نهاية if

Sheets("po_rec").Cells(a, 14).Value = "ok"

وأعتقد أنه من المفترض أن يتم تنفيذه إذا تحقق الشرط يعني قبل نهاية end if

* ثانيا في جملة with يفترض أنك في العمود A وفي آخر صف مكتوب فكيف تنقل القيم في الصفوف السابقة (يفترض أنها مكتوب فيها) لأن ناتج الرقم الأول في offset بالسالب 4 - 21 = -17 ؟؟؟؟

************

ورغم كل شيء:
للخروج من الحلقة التكرارية for يمكنك كتابة exit for قبل سطر نهاية end if

ولكن بعد معالجة الملاحظتين السابقتين

[gamalin2]

اشكرك اخي الكريم لكن

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

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

[أ / محمد صالح]

اعذرني حيث أن المطلوب غير واضح لي

لكن حسب فهمي

أنك تريد نقل البيانات في الصفوف رقم 4 و 6 و7 و8 وآخر قيمة في الصف الأخير وكلها في العمود الأول من شيت recept

وكتابة ok إذا تحقق الشرط والخروج من التكرار إذا تحقق الشرط

إن كان فهمي صحيحا فهذا هو التعديل:

Sub recp_fill()
Application.ScreenUpdating = False
 For a = 5 To [a10000].End(xlUp).Row
    If Cells(a, 2) <> "" And Cells(a, 13) = "recept1" Or Cells(a, 13) = "recept2" Or Cells(a, 13) = "recept3" Or Cells(a, 13) = "recept4" Or Cells(a, 13) = "recept5" Or Cells(a, 13) = "recept6" And Cells(a, 14) <> "ok " Then
    Sheets("po_rec").Cells(a, 14).Value = "ok"
         With Sheets("recept").[a10000].End(xlUp)
              .Offset(4- .row, 1) = Cells(a, 2)
              .Offset(6- .row, 1) = Cells(a, 5)
              .Offset(7- .row, 1) = Cells(a, 6)
              .Offset(8- .row, 1) = Cells(a, 7)
              .offset(0, 1) = Cells(a, 13)
         End With
		exit for
     End If
  Next a
Application.ScreenUpdating = True
MsgBox "!تم الترحيل بنجاح", vbInformation + vbMsgBoxRight, "تم الترحيل"
Range("b6").Select
End Sub

بالتوفيق

[gamalin2]

الاخوة الافاضل 

لدي ملف فيه سجل عن طلب سلعة ما تستورد 

واريد عند تغيير الحالة و الضغط على زر تنفيذ ينقل البيانات لشاشة recept  كتبت كود و خليته يكتب ok علشان الكود ينزل للسطور الثانية لكن اكتشفت اني محتاج اغير تاني حالة نفس الطلب  

بمعنى عند تغيير الحالة من po الى recept1 يتم التنفيذ و عند تغييرها مرة اخرى الى recept2 يتم التنفيذ ايضا ونقل البيانات الى صفحة recept 

بفكر في اني اجعله عند التغيير من po الى recept1 والتنفيذ يكتب recept1 في العمود التالي وعند تغيير الحالة الى recept2 وبقاء العمود المجاور recept1 معنى ذلك ان الحالة تغيرت وعندها ينفذ الكود 

واذا لم تتغير الحالة يعني العمودين متساويتين ينزل للصف التالي 

refill.xlsm

[احمدزمان]

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

 

لست فاهم 

ممكن توضح اكثر

يعني هوه بعد تعبئة الجدول بيرحل الى ورقة ثالثة

اذا ممكن نضع الشرط مربوط ب الورقة الثالثة التي بها كل البيانات

صح

 

[gamalin2]

يا استاذنا جزاك الله خيرا لمحاولتك المساعدة 

المطلوب في شيت PO_REC عند تغيير خانة في عمود 13 وتصبح غير مساوية للخانةفي عمود 14 عند الضغط على زر التنفيذ يتم نقل بعض البيانات الى شيت RECEPT 

الكود اعلاه يعمل جيدا ولكنه يعمل لسطرين فقط

[احمدزمان]

15 دقائق مضت, gamalin2 said:

الكود اعلاه يعمل جيدا ولكنه يعمل لسطرين فقط

لانك في سطرين فقط كاتب ok في العمود 14

و السطور الثانية لا يوجد بها اوكي

 

[أ / محمد صالح]

ما السبب في تكرار المواضيع؟؟ 

🤔😎🤔

 

[gamalin2]

استاذنا الفاضل الموضوع ليس مكررا بل الملف فقط 

عندما وضعت المشاركة الاولى كنت اريد الخروج من الحلقة التكرارية for next والحمد لله اكرمك الله ودللتني على exit for 

ولكن عندما طبقت الكود ينفذ في السطرين الاولين فقط ولا يكمل باقي الصفوف .. ولا ادري ما المشكلة 

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

عموما اشكركم للاهتمام تحياتي لكما 

[أ / محمد صالح]

أخي الكريم

حضرتك لم ترد على الموضوع السابق

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

.شكرا لكلماتك الطيبة وأرجو أن تكون وصلت لمبتغاك غير الواضح لنا جميعا

[gamalin2]

اخي الكريم صحيح لم اجري التعديلات السابقة لاني كما قلت لك سابقا هناك اني تحايلت على جهلي باني طرحت من الرقم -21 وادى الغرض ولم تتح لي فرصة تجربة الكود اللي تفضلت به وهو كان لتحسين الكود لكن الغرض كان متحقق 

المبتغى باختصار بغض النظر عن الكود خالص اذا قبلت 

في شيت po_rec عدة سطور مطلوب نقل بياناتها الى شيت recept في عمود b 

ثم يطبع في الخانة المجاورة في عمود 14 في نفس شيت po_recept  نفس محتوى خانة عمود 13 

عندما يتحقق شرط 

ان تكون الخانة ي عمود 13 تساوي recept1    الى recept6 وايضا تكون لا تساوي الخانة المجورة في عمود 14

لماذا ؟

لان الطلب الواحد سيتم استلام عليه عدد من الرسائل واريد عند تغيير الحالة من recep 1 .... الى recept 6 اي ستة رسائل لنفس الطلب وستة مرات تغيير في خانة الحالة كل مرة اغير الحالة وانفذ الكود 

وكنت بمساعدتك توصلت للكود ده لكنه يعمل جيدا ي سطرين فقط ويتوقف ولا ادري ما السبب 

ارجوا ان يكون المطلوب وضح وعموما اشكرك كثيرا لمحاولتك المساعدة و على وقتك تحياتي لك

[gamalin2]

اخي الكريم 

تم تربة الكود اعلاه 

السطر ده كتب في نفس الشيت شيت ال Po_rec وليس في الشيت المطلوب شيت recept 

و باقي البيانات صارت ترحل في اسطر متباعدة بعيدة عن الجدول او الاماكن المطلوبة في شيت recept 

جزاك الله خير لتعبك شاكر لفضلك 

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

 

              .cells(.row, 1) = Cells(a, 13)

[أ / محمد صالح]

مفيش تعب ولا حاجة. الله في عون العبد مادام العبد في عون أخيه

بالنسبة لهذا السطر جرب استعمال هذا بدلا منه

.offset(0, 1) = Cells(a, 13)

وهو بنفس المعنى الكتابة في نفس الصف والعمود التالي

أما موضوع الأرقام السابقة 

.Offset(4- .row, 1) = Cells(a, 2)

فهذا كما قلت حسب فهمي أنك تريد الكتابة في الصف 4 و 6 و7 بالذات مهما زاد عدد الصفوف.

اقتباس

انا اريد الادخال في الجدول في السطر 4 و 6 و هكذا ولكن الكود اللي استخدمته يذهب الى اخر سطر لهذا طرحت 21 من كل خانة

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

أما الأعمدة والخلايا التي يأخذ منها الكود القيم فهي كما هي في الكود

لم يتم تغييرها

[gamalin2]

اشكرك اخي الكريم تم المطلوب و الحمد لله بشأن الارقام والكتابة بس انا مش قادر افهم برضه يه الكود بيعمل جيدا في اول سطرين من ملف po_rec ويتوقف لكن يعطي رسالة الترحيل رغم انها بين حدي الشرط if , end if  وعلى حسب فهمي ان مادام كتبها يبقى الشرط تحقق  طيب ليه لم يكم باقي الاوامر اللي بين الحدين هتجنن صراحة ومن الصبح فاتح الكود وعمال اغير فيه وماتوصلتش لحاجة ومش عارف انقل لخطوة تانية 

عموما شكرك اخي الكريم تعبت معايا 

[أ / محمد صالح]

الكود الخاص بك يمر خلال الصفوف من 5 إلى آخر صف مكتوب في الشيت النشط

ثم يختبر الشروط الكثيرة هذه على الصف النشط

فإذا تحققت الشروط في صف معين يتم الترحيل ويخرج من الحلقة التكرارية (أي يتوقف عند الصف الذي تحققت فيه الشروط  ولا يكمل إلى آخر صف)
ثم يعرض الرسالة ويحدد الخلية B6

ما الذي تراه خطأ في هذه الآلية؟؟؟؟

[gamalin2]

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

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

Sub recp_fill()
Application.ScreenUpdating = False
 For I = 5 To [a10000].End(xlUp).Row
    If Cells(I, 14) <> Cells(I, 13) And Cells(I, 13) = "recept1" Or Cells(I, 13) = "recept2" Or Cells(I, 13) = "recept3" Or Cells(I, 13) = "recept4" Or Cells(I, 13) = "recept5" Or Cells(I, 13) = "recept6" Then
         With Sheets("recept").[a10000].End(xlUp)
              .Offset(-17, 1) = Cells(I, 2)
              .Offset(-15, 1) = Cells(I, 5)
              .Offset(-14, 1) = Cells(I, 6)
              .Offset(-13, 1) = Cells(I, 😎
              .Offset(0, 1) = Cells(I, 13)
               Sheets("po_rec").Cells(I, 14).Value = Cells(I, 13)
             ' MsgBox "!تم الترحيل   بنجاح", vbInformation + vbMsgBoxRight, "تم الترحيل"
         End With
        Exit For
     End If
  Next I
Application.ScreenUpdating = True
Range("b6").Select
End Sub

 

[أ / محمد صالح]

أين الملف حتى يمكننا معرفة مكان الخطأ

الكود وحده عملية نظرية بحتة

[حسين مامون]

بعد ادن استاد محمد صلاح واتراء للموضوع  .. جرب هذا الكود 

 

Option Explicit

Sub RCT()
Dim Ws As Worksheet
Dim Ws2 As Worksheet
Dim lr1, lr2
Dim x, y
Dim arr
Set Ws = Sheets("po_rec")
Set Ws2 = Sheets("recept")
Application.ScreenUpdating = False
With Ws
lr1 = .Cells(Rows.Count, 1).End(3).Row
arr = Array("recept1", "recept2", "recept3", "recept4", "recept5", "recept6")
For x = 5 To lr1
For Each y In arr
        If .Cells(x, 14).Text = "ok" Then GoTo 1
        If .Cells(x, 13).Text = y Then
         Ws2.Cells(3, 2).Value = .Cells(x, 1)
         Ws2.Cells(4, 2).Value = .Cells(x, 2)
         Ws2.Cells(5, 2).Value = .Cells(x, 3)
         Ws2.Cells(6, 2).Value = .Cells(x, 5)
         Ws2.Cells(7, 2).Value = .Cells(x, 6)
         Ws2.Cells(8, 2).Value = .Cells(x, 8)
          Ws2.Cells(21, 2).Value = .Cells(x, 13)
        .Cells(x, 14) = "ok": GoTo 1
         If y = "recept6" Then Exit Sub
         End If
Next y
1: Next x
End With
Application.ScreenUpdating = True
End Sub

الملف 

refill.xlsm

[أ / محمد صالح]

بعد التجربة على الملف المرفق من الأستاذ حسين تبين لي ما يلي:

مشكلة الكود الموجود في المشاركة رقم 1 هو وجود مسافة بعد ok في الشرط رغم أنها تكتب بدون مسافة في الكود

And Cells(a, 14) <> "ok " Then

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

وبعد فهمي للمطلوب عمليا يمكن تعديل الكود للتالي:

Sub recp_fill2()
Application.ScreenUpdating = False
For I = 5 To [a10000].End(xlUp).Row
If Cells(I, 14) <> Cells(I, 13) And Left(Cells(I, 13), 6) = "recept" Then
With Sheets("recept")
.Cells(4, 2) = Cells(I, 2)
.Cells(6, 2) = Cells(I, 5)
.Cells(7, 2) = Cells(I, 6)
.Cells(8, 2) = Cells(I, 8)
.Cells(21, 2) = Cells(I, 13)
End With
Cells(I, 14) = Cells(I, 13)
Exit For
End If
Next I
Application.ScreenUpdating = True
MsgBox "!تم الترحيل بنجاح", vbInformation + vbMsgBoxRight, "تم الترحيل"
Range("b6").Select
End Sub

مشكلتنا فعلا هي عدم القدرة على تحديد وتوصيل المطلوب بطريقة صحيحة

بالتوفيق

[gamalin2]

الاخوة الافاضل الكواد رائعة وتم المطلوب بكفاءة ودقة تااااامة اشكر لكم تعبكم و رغبتكم في مساعدتي 

مجموعة اكواد ذكية وبارعة 

اشكركم وتحياتي لكم ولكل من مر بالموضوع وساهم او تعلم 

مرة اخرى تحياتي لكم زادكم الله من فضلة ومن علمه