أكاديمية الصقر للتدريب

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


أهلا وسهلا بك زائرنا الكريم في أكاديمية الصقر للتدريب، لكي تتمكن من المشاركة ومشاهدة جميع أقسام المنتدى وكافة الميزات ، يجب عليك إنشاء حساب جديد بالتسجيل بالضغط هنا أو تسجيل الدخول اضغط هنا إذا كنت عضواً .





ايقاف الكود عندما تكون الخلايا فارغة

السلام عليكم اخوااتى استاذ ياسر ربنا يكرمه هو والاستاذ سليم ربنا يحفظكم يارب احتاج تعديل عى كود الترحيل الذى اهدانى اياه ..



07-06-2020 05:11 مساء
omhamzh
عضو فعال
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 27-05-2020
رقم العضوية : 19308
المشاركات : 137
الجنس : أنثى
يتابعهم : 1
يتابعونه : 0
قوة السمعة : 225
 offline 

السلام عليكم اخوااتى
استاذ ياسر ربنا يكرمه هو والاستاذ سليم ربنا يحفظكم يارب
احتاج تعديل عى كود الترحيل الذى اهدانى اياه اخى فى الله الاستاذ ياسر
انا حاولت كتير من امس وفشلت
عدلت حاجة واحدة ونجحت  عندما تكون خلية a2 التاريخ فرغة الكود يقف ويخرج رسالة برجاء ادخال التاريخ وللامانة احد الاخوة الى عليها
احتاج عندما تكون خلية c2 فارغة ايضا يقف ويكتب رجاء ادخال رقم الفاتورة
ايضا f2 اذا كانت فارغة برجاء اختيار المخزن
واذا تم الكتابة فىb3 ولم يكتب فىd3 وe3 برجاء اكمال البيانات
وهكذا مع باقى الاسطر 
لتجنب نسيان اى بيان لان الكود يرحل بغض النظر هل البيانات كاملة او لم تكتمل
لا احتاج تعديل فى كود الترحيل الكود يعمل ممتاز بس احتاج تنبيه باكمال البيانات
مع خالص الشكر والتقدير
Sub Test()
    Dim x, ws As Worksheet, sh As Worksheet, sName As String, r As Long, m As Long, n As Long, rng As Range
        Set rng = Sheet1.Range("A2")
    If rng.Value = "" Then MsgBox "اكتب التاريخ من فضلك", vbExclamation: Exit Sub
    'إيقاف اهتزاز الشاشة
    Application.ScreenUpdating = False
        'ورقة العمل المسماة صفحة الترحيل
        Set ws = Sheet1
        'المتغير لمعرفة رقم آخر صف به بيانات في العمود الثاني
        m = ws.Cells(Rows.Count, "B").End(xlUp).Row
        'حلقة تكرارية من الصف رقم 3 إلى آخر صف به بيانات
        For r = 3 To m
            'متغير لتخزين اسم ورقة العمل التي سيتم الترحيل إليها
            sName = ws.Cells(r, 5).Value
            'التأكد من وجود ورقة العمل التي سيتم الترحيل إليها
            If Evaluate("ISREF('" & sName & "'!A1)") Then
                'تعيين ورقة العمل التي سيتم الترحيل إليها
                Set sh = ThisWorkbook.Worksheets(sName)
                'تحديد أول صف فارغ في ورقة العمل المراد الترحيل إليها لوضع البيانات بها
                n = sh.Cells(Rows.Count, 1).End(xlUp).Row + 1
                With sh
                    'ترحيل التاريخ
                    .Cells(n, 1).Value = ws.Cells(2, 1).Value
                    'ترحيل الاسم
                    .Cells(n, 2).Value = ws.Cells(r, 2).Value
                    'ترحيل رقم الفاتورة
                    .Cells(n, 3).Value = ws.Cells(2, 3).Value
                    'معرفة رقم العمود الخاص بالمخزن ليتم إدراج المبلغ فيه
                    x = Application.Match(ws.Cells(2, 6).Value, sh.Rows(1), 0)
                    If Not IsError(x) Then
                        .Cells(n, x).Value = ws.Cells(r, 4).Value
                    End If
                End With
            Else
                Debug.Print "Worksheet " & sName & " Doesn't Exist"
            End If
        Next r
    'استعادة خاصية اهتزاز الشاشة
    Application.ScreenUpdating = True
            Range("A3:f24").ClearContents

    MsgBox "تم الترحيل بنجاح", 64, ""

End Sub



 
 
 
  تصميم صفحة.xlsm   تحميل xlsm مرات التحميل :(7)
الحجم :(35.123) KB


07-06-2020 10:04 مساء
مشاهدة مشاركة منفردة [1]
YasserKhalil
مراقب عام
معلومات الكاتب ▼
تاريخ الإنضمام : 21-08-2017
رقم العضوية : 3
المشاركات : 10445
الجنس : ذكر
تاريخ الميلاد : 1-10-1978
الدعوات : 24
يتابعهم : 1
يتابعونه : 535
قوة السمعة : 36552
عدد الإجابات: 254
 offline 
look/images/icons/i1.gif ايقاف الكود عندما تكون الخلايا فارغة
وعليكم السلام
لا أعلم لما الخوف من محاولة التعديل على الكود ..
الأمر بسيط جداً ..لاحظي الأسطر وكرري الأسطر بالشكل الذي يمكنك من اختبار جميع الخلايا المطلوبة
If Sheet1.Range("A2").Value = "" Then MsgBox "اكتب التاريخ من فضلك", vbExclamation: Exit Sub
If Sheet1.Range("C2").Value = "" Then MsgBox "برجاء إدخال رقم الفاتورة", vbExclamation: Exit Sub

07-06-2020 10:08 مساء
مشاهدة مشاركة منفردة [2]
YasserKhalil
مراقب عام
معلومات الكاتب ▼
تاريخ الإنضمام : 21-08-2017
رقم العضوية : 3
المشاركات : 10445
الجنس : ذكر
تاريخ الميلاد : 1-10-1978
الدعوات : 24
يتابعهم : 1
يتابعونه : 535
قوة السمعة : 36552
عدد الإجابات: 254
 offline 
look/images/icons/i1.gif ايقاف الكود عندما تكون الخلايا فارغة
أما فيما يخص الخلايا التي تقع داخل الحلقة التكرارية أي بعد هذا السطر
 For r = 3 To m

فستكون الإشارة للعمود المطلوب التعامل معه وفحص الخلية الخاصة به
على سبيل المثال
لو كانت الخلية المطلوب فحصها هي الخلية B3 فهذه الخلية داخل الحلقة التكرارية سيرمز للصف بالرمز r والعمود B هو العمود الثاني
لذا ستكون الإشارة للخلية بشكل مختلف قليلاً
If Sheet1.cells(r,2).Value = "" Then MsgBox "برجاء إكمال البيانات", vbExclamation: Exit Sub

لاحظي الإشارة لرقم الصف يكون باستخدام المتغير r ، والإشارة للعمود تكون برقم ، وكما ضربت بالمثال العمود الثاني هو العمود B ورقمه هو 2 ..

أرجو أن يكون الرد مفيداً في وصولك لحل ، أما الحلول الجاهزة فلا أعترف بها في الوقت الحالي .. لأنني أيقنت أنها مضيعة للوقت والجهد ، والكثير من الناس لم يتعلم بالحلول الجاهزة.

07-06-2020 10:10 مساء
مشاهدة مشاركة منفردة [3]
omhamzh
عضو فعال
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 27-05-2020
رقم العضوية : 19308
المشاركات : 137
الجنس : أنثى
يتابعهم : 1
يتابعونه : 0
قوة السمعة : 225
 offline 
look/images/icons/i1.gif ايقاف الكود عندما تكون الخلايا فارغة
الله يبارك لحضرتك تمام
انا هذه الجملة تعلمتها تمام
بس الجملة التى تحوى شرط لو كتبنا فى خلية مثلا b ونسينا نكتب فى d او e اوf
والعكس لو نسينا نكتب فى b وكتبنا d او e ومكتبناش f
 صعبة جدا عليا استاذى انا من امبارح ببحث فى كل مواضيع حضرتك على الانترنت فى كل المواقع واحاول اتعلم من
ابداعاتك وربنا يسهل 
احتاج هذا التعديل مشكور اخى
 

07-06-2020 10:23 مساء
مشاهدة مشاركة منفردة [4]
YasserKhalil
مراقب عام
معلومات الكاتب ▼
تاريخ الإنضمام : 21-08-2017
رقم العضوية : 3
المشاركات : 10445
الجنس : ذكر
تاريخ الميلاد : 1-10-1978
الدعوات : 24
يتابعهم : 1
يتابعونه : 535
قوة السمعة : 36552
عدد الإجابات: 254
 offline 
look/images/icons/i1.gif ايقاف الكود عندما تكون الخلايا فارغة
يمكن في استخدام الشرط الجمع بين أكثر من شرط باستخدام AND ...أو إذا كنتي تريدين فحص ما إذا كانت أي خلية فارغة تستخدم OR
مثال 
If Sheet1.Cells(r,2).Value="" Or Sheet1.Cells(r,4).Value=""  Then

ثم ضعي الرسالة ما بين شطري جملة الشرط وفي النهاية جملة End If

07-06-2020 10:28 مساء
مشاهدة مشاركة منفردة [5]
omhamzh
عضو فعال
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 27-05-2020
رقم العضوية : 19308
المشاركات : 137
الجنس : أنثى
يتابعهم : 1
يتابعونه : 0
قوة السمعة : 225
 offline 
look/images/icons/i1.gif ايقاف الكود عندما تكون الخلايا فارغة
الله يفتح عليك استاذنا
عملتها بس واجهت مشكلة مش عارفة ايه السبب
Sub Test()
    Dim x, ws As Worksheet, sh As Worksheet, sName As String, r As Long, m As Long, n As Long, rng As Range
        Set rng = Sheet1.Range("A2")
    If rng.Value = "" Then MsgBox "اكتب التاريخ من فضلك", vbExclamation: Exit Sub
    If Sheet1.Range("C2").Value = "" Then MsgBox "برجاء إدخال رقم الفاتورة", vbExclamation: Exit Sub
        If Sheet1.Range("f2").Value = "" Then MsgBox "برجاء إدخال رقم المخزن", vbExclamation: Exit Sub
    'إيقاف اهتزاز الشاشة
    Application.ScreenUpdating = False
        'ورقة العمل المسماة صفحة الترحيل
        Set ws = Sheet1
        'المتغير لمعرفة رقم آخر صف به بيانات في العمود الثاني
        m = ws.Cells(Rows.Count, "B").End(xlUp).Row
        'حلقة تكرارية من الصف رقم 3 إلى آخر صف به بيانات
        For r = 3 To m
            If Sheet1.Cells(r, 2).Value = "" Then MsgBox "برجاء إكمال البيانات", vbExclamation: Exit Sub
    If Sheet1.Cells(r, 4).Value = "" Then MsgBox "برجاء إكمال البيانات", vbExclamation: Exit Sub
        If Sheet1.Cells(r, 5).Value = "" Then MsgBox "برجاء إكمال البيانات", vbExclamation: Exit Sub

            'متغير لتخزين اسم ورقة العمل التي سيتم الترحيل إليها
            sName = ws.Cells(r, 5).Value
            'التأكد من وجود ورقة العمل التي سيتم الترحيل إليها
            If Evaluate("ISREF('" & sName & "'!A1)") Then
                'تعيين ورقة العمل التي سيتم الترحيل إليها
                Set sh = ThisWorkbook.Worksheets(sName)
                'تحديد أول صف فارغ في ورقة العمل المراد الترحيل إليها لوضع البيانات بها
                n = sh.Cells(Rows.Count, 1).End(xlUp).Row + 1
                With sh
                    'ترحيل التاريخ
                    .Cells(n, 1).Value = ws.Cells(2, 1).Value
                    'ترحيل الاسم
                    .Cells(n, 2).Value = ws.Cells(r, 2).Value
                    'ترحيل رقم الفاتورة
                    .Cells(n, 3).Value = ws.Cells(2, 3).Value
                    'معرفة رقم العمود الخاص بالمخزن ليتم إدراج المبلغ فيه
                    x = Application.Match(ws.Cells(2, 6).Value, sh.Rows(1), 0)
                    If Not IsError(x) Then
                        .Cells(n, x).Value = ws.Cells(r, 4).Value
                    End If
                End With
            Else
                Debug.Print "Worksheet " & sName & " Doesn't Exist"
            End If
        Next r
    'استعادة خاصية اهتزاز الشاشة
    Application.ScreenUpdating = True
            Range("A3:f24").ClearContents

    MsgBox "تم الترحيل بنجاح", 64, ""

End Sub

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

07-06-2020 10:36 مساء
مشاهدة مشاركة منفردة [6]
salim
خبير معتمد
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 22-08-2017
رقم العضوية : 43
المشاركات : 853
الجنس : ذكر
تاريخ الميلاد : 1-5-1989
الدعوات : 1
يتابعهم : 13
يتابعونه : 33
قوة السمعة : 6607
عدد الإجابات: 67
 offline 
look/images/icons/i1.gif ايقاف الكود عندما تكون الخلايا فارغة

كتابة هذا الشرط في المكان المناسب  (حسب الصورة)


MjIyMTYzMQ8585myCode
 
 





الكلمات الدلالية
ايقاف ، الكود ، عندما ، تكون ، الخلايا ، فارغة ،


 










اخلاء مسئولية: يخلى منتدى أكاديمية الصقر للتدريب مسئوليته عن اى مواضيع او مشاركات تندرج داخل الموقع ويحثكم على التواصل معنا ان كانت هناك اى إنتهاكات تتضمن اى انتهاك لحقوق الملكية الفكرية او الادبية لاى جهة - بالتواصل معنا من خلال نموذج مراسلة الإدارة .وسيتم اتخاذ الاجراءات اللازمة.
سياسة النشر: التعليقات المنشورة لا تعبر عن رأي منتدى أكاديمية الصقر للتدريب ولا نتحمل أي مسؤولية قانونية حيال ذلك ويتحمل كاتبها مسؤولية النشر.

الساعة الآن 08:36 صباحا