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

[aboud424]

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

شكرا لكم مسبقا

TADJERIB.rar

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

السلام عليكم

ممكن مزيد من التفاصيل حول المطلوب حيث اطلعت على الملف ولم أفهم المطلوب بشكل كامل

 

[aboud424]

يوجد معلومات اريد ملؤها في الجدول

بحيث فطور الصباح ينقل لخانة فطور الصباح والخانة الدلائلية هي E117

ص يعني الصباح

غ يعني الغداء

ع يعني العشاء

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

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

جرب الكود التالي لعله يفي بالغرض

Sub Test()
    Dim arr     As Variant
    Dim arBr    As Variant
    Dim arLu    As Variant
    Dim arDi    As Variant
    Dim i       As Long
    Dim j       As Long
    Dim b       As Long
    Dim l       As Long
    Dim d       As Long

    arr = Range("A117:E" & Cells(Rows.Count, 1).End(xlUp).Row).Value
    ReDim arBr(1 To UBound(arr, 1), 1 To UBound(arr, 2) - 1)
    ReDim arLu(1 To UBound(arr, 1), 1 To UBound(arr, 2) - 1)
    ReDim arDi(1 To UBound(arr, 1), 1 To UBound(arr, 2) - 1)

    For i = 1 To UBound(arr, 1)
        If arr(i, 5) = "ص" Then
            b = b + 1
            For j = 1 To 3
                arBr(b, j) = arr(i, j)
            Next j
            arBr(b, 4) = arBr(b, 2) * arBr(b, 3)
        ElseIf arr(i, 5) = "غ" Then
            l = l + 1
            For j = 1 To 3
                arLu(l, j) = arr(i, j)
            Next j
            arLu(l, 4) = arLu(l, 2) * arLu(l, 3)
        ElseIf arr(i, 5) = "ع" Then
            d = d + 1
            For j = 1 To 3
                arDi(d, j) = arr(i, j)
            Next j
            arDi(d, 4) = arDi(d, 2) * arDi(d, 3)
        ElseIf arr(i, 5) = "م" Then
            l = l + 1
            d = d + 1
            For j = 1 To 3
                arLu(l, j) = arr(i, j)
                arDi(d, j) = arr(i, j)
            Next j
            arLu(l, 4) = arLu(l, 2) * arLu(l, 3)
            arDi(d, 4) = arDi(d, 2) * arDi(d, 3)
        End If
    Next i

    Range("B16").Resize(b, UBound(arBr, 2)).Value = arBr
    Range("B26").Resize(l, UBound(arLu, 2)).Value = arLu
    Range("B67").Resize(d, UBound(arDi, 2)).Value = arDi
End Sub

 

[aboud424]

هكذا ظهر عند التفعيل

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

ارفق الملف الذي يظهر به الخطأ لأن الكود مجرب ويعمل بشكل جيد على الملف في المشاركة الأصلية للموضوع ..

[aboud424]

الاستاذ ياسر خليل ابو البراء

في الحقيقة هذا هو الملف الاصلي اردت التغيير عليه. ارجو مساعدتي 

Classeur3.rar

[aboud424]

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

تم تعديل يونيو 14, 2017 بواسطه aboud424

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

يتعذر العمل على الجهاز بشكل كامل الآن .. إن شاء الله إذا لم يتدخل أحد الأخوة سأحاول العمل عليه ليلاً أو غداً إن شاء الله

وأريد توضيح بمثال لشرط المناصفة لتتضح الصورة ..

[aboud424]

مثال عن ذلك البطاطا

في 1 mai قيمتها بطاطا = 3كلغ وهي من المواد المشتركة

فترة الغداء دائما تاخد اكبر كمية من المساء بمعنى

الغداء قيمة البطاطا فيه = 2 كلغ

بينما الباقي ياخذه العشاء = 1كلغ

مثال اخر

في 2 mai

قيمة مادة مشتركة اللحم = 1.5 كلغ   =====>  الغداء =1كلغ

                                                 |======>العشاء =0.5كلغ وهي الاقيمة المتبقية

 

 

باركة الله فيك اخي الكريم تحياتي

تم تعديل يونيو 14, 2017 بواسطه aboud424

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

جرب التعديل التالي عله يفي بالغرض (ويرجى فيما بعد حين تطرح موضوع أن ترفق الملف الأصلي أو ملف معبر عنه تماماً لكي يسير العمل بشكل منتظم وكما هو مطلوب ومتوقع)

Sub Test()
    Dim arr     As Variant
    Dim arBr    As Variant
    Dim arLu    As Variant
    Dim arDi    As Variant
    Dim i       As Long
    Dim j       As Long
    Dim b       As Long
    Dim l       As Long
    Dim d       As Long

    arr = Range("A116:E" & Cells(Rows.Count, 1).End(xlUp).Row).Value
    ReDim arBr(1 To UBound(arr, 1), 1 To UBound(arr, 2) - 1)
    ReDim arLu(1 To UBound(arr, 1), 1 To UBound(arr, 2) - 1)
    ReDim arDi(1 To UBound(arr, 1), 1 To UBound(arr, 2) - 1)

    For i = 1 To UBound(arr, 1)
        If arr(i, 4) = "ص" Then
            b = b + 1
            For j = 1 To 3
                arBr(b, j) = arr(i, j)
            Next j
            arBr(b, 4) = arBr(b, 2) * arBr(b, 3)
        ElseIf arr(i, 4) = "غ" Then
            l = l + 1
            For j = 1 To 3
                arLu(l, j) = arr(i, j)
            Next j
            arLu(l, 4) = arLu(l, 2) * arLu(l, 3)
        ElseIf arr(i, 4) = "ع" Then
            d = d + 1
            For j = 1 To 3
                arDi(d, j) = arr(i, j)
            Next j
            arDi(d, 4) = arDi(d, 2) * arDi(d, 3)
        ElseIf arr(i, 4) = "م" Then
            l = l + 1
            d = d + 1
            For j = 1 To 3
                arLu(l, j) = arr(i, j)
                arDi(d, j) = arr(i, j)
            Next j
            arLu(l, 2) = Application.WorksheetFunction.Round(arLu(l, 2) * 2 / 3, 2)
            arDi(d, 2) = Application.WorksheetFunction.Round(arDi(d, 2) * 1 / 3, 2)
            arLu(l, 4) = arLu(l, 2) * arLu(l, 3)
            arDi(d, 4) = arDi(d, 2) * arDi(d, 3)
        End If
    Next i

    Range("B15").Resize(b, UBound(arBr, 2)).Value = arBr
    Range("B24").Resize(l, UBound(arLu, 2)).Value = arLu
    Range("B65").Resize(d, UBound(arDi, 2)).Value = arDi
End Sub

 

[aboud424]

السلام عليك استاذ ياسر خليل

اعذرني على الخربطة في الشرح.  

عند تجريبي الكود هذه النتيجة عندي. شكرا لك 

Classeur3+1.rar

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

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

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

ملحوظة أخرى يفضل إدراج موديول جديد ووضع الكود فيه وليس وضعه في حدث ورقة العمل 

جرب مرة أخرى وأعملني بالنتيجة

[aboud424]

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

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

وعليكم السلام أخي العزيز .. وكل عام وأنت بخير

الحمد لله أن تم المطلوب على خير والحمد لله الذي بنعمته تتم الصالحات

تقبل وافر تقديري واحترامي