رجاء تحويل هذة المعادلات الى كود

[رفيع سعد]

بسم الله الرحمن الرحيم

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

Book1.rar

[الجموعي]

تحويل  المعادلات الى كود

تفضل الكود

Sub Formula()

    Range("K3").Formula = "=IF(M3<=1,"""",IF(M3>=1,B3))"
    Range("K4").Formula = "=IF(M4<=1,"""",IF(M4>=1,C3))"
    Range("K5").Formula = "=IF(M5<=1,"""",IF(M5>=1,D3))"
    Range("K6").Formula = "=IF(M6<=1,"""",IF(M6>=1,E3))"
    Range("K7").Formula = "=IF(M7<=1,"""",IF(M7>=1,B9))"
    Range("K8").Formula = "=IF(M8<=1,"""",IF(M8>=1,C9))"
    Range("K9").Formula = "=IF(M9<=1,"""",IF(M9>=1,D9))"
    Range("K10").Formula = "=IF(M10<=1,"""",IF(M10>=1,E9))"
    Range("K11").Formula = "=IF(M11<=1,"""",IF(M11>=1,B15))"
    Range("K12").Formula = "=IF(M12<=1,"""",IF(M12>=1,C15))"
    Range("K13").Formula = "=IF(M13<=1,"""",IF(M13>=1,D15))"
    Range("K14").Formula = "=IF(M14<=1,"""",IF(M14>=1,E15))"

End Sub

[رفيع سعد]

السلام عليكم 

اخى الجموعى متشكر على الرد لكن المطلوب تحويل المعادلة الى كود وازالة فراغات الخلايا

[سليم حاصبيا]

اكتب هذا الكود  في حدث الصفحة

Sub FULFORMULA()
Range("K3").Formula = "=IF(M3<=1,"""",IF(M3>=1,B3))"

 Range("k3").Select
    Selection.AutoFill Destination:=Range("k3:k14"), Type:=xlFillDefault
End Sub

[سليم حاصبيا]

 تم تغيير الملف لاصابته بفيروس

مجرد ما تنقر الخلية C16  وتحرج منها تنتقل قيمتها الى الى العامود D

[ibn_egypt]

اخى الفاضل

 

وبعد إذن أساتذتي الكرام أ.سليم وأ.الجموعي، جرب الملف المرفق لربما به طلبك

 

تحياتي  

Transfer-Products.rar

[رفيع سعد]

بسم الله الرحمن الرحيم

الاساتذة الافاضل السلام عليكم ورحمة الله وبركاتة شكرا لكم على الرد وبالنسبة لملف الاستاذ الفاضل ابن مصر فعلا هو دة المطلوب واطلب من حضرتك بعد اذنك شرح بسيط للكود لانى حابب افهم وكمان بعد اذنك بعد الترحيل عايز البيانات تتمسح من خلايا الكمية ويتم ترحيل بيانات الاعمدة من o4:z4 الى شيت 3 ولك منى جزيل الشكر

[ibn_egypt]

 

بسم الله الرحمن الرحيم

الاساتذة الافاضل السلام عليكم ورحمة الله وبركاتة شكرا لكم على الرد وبالنسبة لملف الاستاذ الفاضل ابن مصر فعلا هو دة المطلوب واطلب من حضرتك بعد اذنك شرح بسيط للكود لانى حابب افهم وكمان بعد اذنك بعد الترحيل عايز البيانات تتمسح من خلايا الكمية ويتم ترحيل بيانات الاعمدة من o4:z4 الى شيت 3 ولك منى جزيل الشكر

 

 

اخى الفاضل

 

حضرتك متأكد من ترحيل النطاق ده .. النطاق ده مش مكتوب فيه الا "الاسم - العدد - صنف1-صنف2" والا انت تقصد الاصناف اللى طلعت وكمياتها واسعارها ... اذا كان كده ما نرحلها مباشرة لشيت 3 وخلاص

 

تحياتي  

[رفيع سعد]

بسم الله الرحمن الرحيم

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

[ibn_egypt]

اخى الفاضل

 

جرب الملف المرفق لربما به طلبك .. هناك زر اسمه فرز الأصناف بالضغط عليه سيجلب لك البيانات في النطاق المحدد .. بعد التأكد منها اضغط ترحيل سيتم ترحيلها الى شيت All ويتم حذف بيانات الكميات

 

تحياتي  

Transfer-Products.rar

[رفيع سعد]

بسم الله الرحمن الرحيم

أستاذى الفاضل ابن مصر أنا اسف أذا كنت بتقل عليك هو فعلا دو المطلوب بالتمام لكن انا كنت عايز الاصناف فى شيت all تكون فى الصف 2 صنف 1 صنف2 صنف3 وهكذا لان هيكون هناك ترحيل لعدد كبير من العملاء فيكون عدد الصفوف 3 صفوف لكل عميل كما فى الملف اللى فى اول الموضوع والطلب الاهم من دة كلة فضلا وتكرما منك شرح بسيط للكود او للاجزاء الهامة منة ويكون لك الف الف شكر

[ibn_egypt]

اخى الفاضل

 

جرب الملف المرفق، تم التعديل بناءا على طلبك

 

تحياتي  

Transfer-Products.rar

[رفيع سعد]

أستاذى الفاضل ابن مصر 

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

تم تعديل فبراير 4, 2015 بواسطه رفيع سعد

[رفيع سعد]

بسم الله الرحمن الرحيم

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

[ياسر خليل أبو البراء]

الاخ الحبيب رفيع

إليك شرح الكود الأول - وكفاية عليا كدا - ..

Sub FilterProduct()
'تعريف المتغيرات
Dim ws As Worksheet
Dim lr, lr2, lr3 As Long
Dim i, y As Integer

'[Data]لورقة العمل التي باسم[ws]تعيين المتغير
Set ws = ThisWorkbook.Sheets("Data")
'تعيين رقم آخر صف به بيانات في العمود الأول
lr = ws.Cells(Rows.Count, 1).End(xlUp).Row
    'إيقاف خاصية إهتزاز الشاشة
    Application.ScreenUpdating = False
        'بدء التعامل مع ورقة العمل
        With ws
            'مسح النطاق الذي تظهر فيه النتائج
            .Range("K3:M1000").ClearContents
            'حلقة تكرارية للعمود الثاني والثالث والرابع والخامس
            For y = 2 To 5
                '[K]متغير لتحديد أول خلية فارغة لطبع النتائج بها في العمود
                lr2 = .Cells(Rows.Count, 11).End(xlUp).Row + 1
                'حلقة تكرارية في الصفوف ابتداءً من الصف الثالث وحتى آخر صف به بيانات ، مع التخطي 6 خطوات
                For i = 3 To lr Step 6
                    'إذا كانت الخلية التي يظهر بها الثمن ليست فارغة وأكبر من واحد
                    If .Cells(i + 2, y).Value <> "" And .Cells(i + 2, y) > 1 Then
                         'تساوي أسماء الأصناف في صفوف الأصناف[K]الخلايا في العمود
                        .Cells(lr2, 11).Value = .Cells(i, y).Value
                         'تساوي الكميات في صفوف الكمية[L]الخلايا في العمود
                        .Cells(lr2, 12).Value = .Cells(i + 1, y).Value
                         'تساوي الأسعار في صفوف الثمن[M]الخلايا في العمود
                        .Cells(lr2, 13).Value = .Cells(i + 2, y).Value
                        'زيادة المتغير بقيمة واحد للانتقال إلى خلية فارغة جاهزة لطبع النتائج بها
                        lr2 = lr2 + 1
                       'إذا لم يتحقق الشرط
                       Else
                        'يبقى المتغير بنفس القيمة بدون زيادة
                        lr2 = lr2
                     End If
                Next i
            Next y
        End With
    'إعادة تفعيل خاصية إهتزاز الشاشة
    Application.ScreenUpdating = True
End Sub

أرجو أن يكون الشرح واضح وصريح ومش محتاج توضيح

الحلقات التكرارية المتشابكة أو المتداخلة دي لا يتقنها إلا محترف مثل ابن مصر

سلمت يمناك يا ابن مصر

[رفيع سعد]

بسم الله الرحمن الرحيم

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

[ياسر خليل أبو البراء]

الأخ المشاكس رفيع سعد

من كان حليفا فليحلف بالله أو ليصمت (متقولش والنبي تاني وإلا مش هعبرك تاني ههههه) ..

أتعبتني ..وولكن ولا يهمك المهم تدعي للكبير ابن مصر ولا تنساني أنا الآخر بدعوة بظهر الغيب

Sub TransferProducts()
    'تعريف المتغيرات
    Dim ws, ws2 As Worksheet
    Dim lr, lr2 As Long
    '[Data]لورقة العمل التي باسم[ws]تعيين المتغير
    Set ws = ThisWorkbook.Sheets("Data")
    '[All]لورقة العمل التي باسم[ws2]تعيين المتغير
    Set ws2 = ThisWorkbook.Sheets("All")
    '[ws]في ورقة العمل[K]تعيين رقم آخر صف به بيانات في العمود
    lr = ws.Cells(Rows.Count, 11).End(xlUp).Row
    '[ws2]تعيين رقم أول صف فارغ في العمود الرابع في ورقة العمل
    lr2 = ws2.Cells(Rows.Count, 4).End(xlUp).Row + 1
    'إيقاف خاصية إهتزاز الشاشة
    Application.ScreenUpdating = False
        'إظهار رسالة تفيد بتأكيد الترحيل من عدمه ، فإذا تم الضغط على زر الأمر لا يتم الخروج من الإجراء الفرعي
        If MsgBox("  هل تريد بالتأكيد ترحيل البيانات ومسحها" & vbCr & vbCr & String$(40, "="), vbCritical + vbYesNo + vbMsgBoxRight + vbMsgBoxRtlReading + vbDefaultButton2, "تاكيد الترحيل ") = vbNo Then Exit Sub
        '[H3:J3]يتم نسخ بيانات الزبون الموجودة في النطاق
        ws.Range("H3:J3").Copy
        '[ws2]بعد عملية النسخ يتم لصق البيانات في العمود الأول في ورقة العمل
        ws2.Range("A" & lr2).PasteSpecial (xlPasteValues)
        'يتم نسخ النتائج التي تم استخراجها من الكود السابق
        ws.Range("K3:M" & lr).Copy
        'يتم لصق البيانات ولكن بشكل أفقي وليس عمودي في بداية العمود الرابع
        ws2.Range("D" & lr2).PasteSpecial (xlPasteValues), , , True
        'إلغاء خاصية النسخ واللصق
        Application.CutCopyMode = False
        '[ws]مسح النطاق الذي يحتوي على النتائج حتى آخر خلية بها بيانات في ورقة العمل
        ws.Range("K3:M" & lr).ClearContents
        '[clear]استدعاء الإجراء الفرعي المسمى
        Call clear
    'إعادة تفعيل خاصية إهتزاز الشاشة
    Application.ScreenUpdating = True
End Sub

Sub clear()
    'تعريف المتغيرات
    Dim ws As Worksheet
    Dim lr, lr2, lr3 As Long
    Dim i, y As Integer
    '[Data]لورقة العمل التي باسم[ws]تعيين المتغير
    Set ws = ThisWorkbook.Sheets("Data")
    '[ws]تعيين رقم آخر صف به بيانات في العمود الأول في ورقة العمل
    lr = ws.Cells(Rows.Count, 1).End(xlUp).Row
    '[ws]بدء التعامل مع ورقة العمل
    With ws
        'حلقة تكرارية للأعمدة من العمود الثاني إلى العمود الخامس
        For y = 2 To 5
            'حلقة تكرارية من الصف الثالث وحتى آخر صف به بيانات
            For i = 3 To lr Step 6
                'يتم مسح الخلاياالتي بها الكميات
                .Cells(i + 1, y).Value = ""
            Next i
        Next y
    End With
End Sub

تم تعديل فبراير 5, 2015 بواسطه YasserKhalil

[ibn_egypt]

يا طول بالك يا كبير

 

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

 

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

 

 تحياتى  

[ياسر خليل أبو البراء]

أخي وحبيبي ابن مصر

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

وتعال هنا قولي مين فينا اللي طويل البال ؟ اللي كتب الكوووووووووووووود الرائع ولا اللي شرحه بشكل عابر

تقبل تحياتي

[رفيع سعد]

بسم الله الرحمن الرحيم

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

[ياسر خليل أبو البراء]

الأخ الحبيب رفيع سعد

لا داعي للأسف فلكنا نخطيء أخي الكريم

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

فلك مني كل التحية والود والتقدير والعرفان بالجميل .. يا أستاذ رفيع يا جميل

[رفيع سعد]

بسم الله الرحمن الرحيم

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

[ياسر خليل أبو البراء]

أخي الحبيب رفيع سعد (طير إنت)

ربنا يكرمك ويبارك فيك ...أنا فعلا لم أنساك ولن أنساك ، ومن استفاد من هذه الحلقات لو عرف إنك نواة هذه الحلقات ، أكيد بردو مش هينسوك

تقبل تحياتي

[رفيع سعد]

بسم الله الرحمن الرحيم 

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

1.rar

تم تعديل فبراير 7, 2015 بواسطه رفيع سعد

[ibn_egypt]

بسم الله الرحمن الرحيم 

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

اخى الفاضل

 

جرب الملف المرفق لربما به طلبك ..

 

تحياتي  

بعد التعديل.rar