ترحيل الإدخالات لاستخراج كمية وقيمة ونوع حديد التسليح

[ياسر حمزه]

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

متابعة المشتريات.rar

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

أخي الكريم الكبير

يرجى تغيير اسم الظهور للغة العربية

كما يرجى مزيد من التوضيح حول ملفك والأفضل أن ترفق نموذج لشكل النتائج المتوقعة ..

ذكرت كلمة المواد في الموضوع وبحثت عنها في الأعمدة الموجودة فلم أجدها ..هل تقصد بالمواد عمود البيان؟؟ يرجى ذكر المسميات كما بالملف المرفق ، لأنه لا يفترض بي أن أفهم طبيعة عملك ..فالنسبة لي الملف يبدو غريب على عكسك ..الملف يبدو لك مألوف أكثر مني

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

تقبل تحياتي

 

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

جرب هذا الملف

 

متابعة المشتريات salim.rar

[ياسر حمزه]

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

متابعة المشتريات.rar

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

أخي الكريم ياسر حمزة

لم تتضح الصورة بعد أيضاً ..ما هو المنطق في الترحيل ؟؟

هل أوراق العمل الموجودة خلاف ورقة عمل الإدخال موجودة بالفعل أم أنك تريد إنشائها بالكود ؟

وماذا عن بقية المدخلات الخاصة بمشروع الفيصل ؟

وماذا عن بقية المواد ..مواسير 6 بوصة و4بوصة؟؟

مزيد من التوضيح أعتقد أنه سيريح

 

[ياسر حمزه]

اخي الكريم ياسر خليل ابو البراء

اشكر سعة صدرك

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

اما بخصوص اوراق العمل فهي اكثر من ذلك و راغب في انشاؤها بالكود

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

و اعتذر عن عدم درايتي بالاكواد و كيفية الترحيل

 

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

أخي الكريم ياسر حمزة إليك محاولة مني لعلها تفي بالغرض

تم إضافة عمود مساعد للجمع بين اسم المشروع والمواد . وعلى أساس هذا العمود المساعد يتم عمل ورقة عمل لكل مادة مميزة داخل المشروع ..

جرب الملف المرفق بنفسك وشوف النتائج

Sub Test()
    Dim A, I As Long, II As Long, myList, E, X, Flg As Boolean
    
    With Sheets("الادخال").Range("A4").CurrentRegion
        A = .Value
        For I = 2 To UBound(A, 1)
            For Each E In Split(A(I, 13), ",")
                If IsEmpty(myList) Then
                    ReDim myList(1 To 2, 1 To 1)
                    myList(1, 1) = Trim$(E)
                    Set myList(2, 1) = .Rows(I): X = 1
                Else
                    For II = 1 To UBound(myList, 2)
                        If myList(1, II) = Trim$(E) Then
                            X = II: Flg = True: Exit For
                        End If
                    Next
                    If Not Flg Then
                        ReDim Preserve myList(1 To 2, 1 To II)
                        myList(1, II) = Trim$(E)
                        Set myList(2, II) = .Rows(I)
                        X = II
                    End If
                End If
                Set myList(2, X) = Union(myList(2, X), .Rows(I))
                Flg = False
            Next
        Next
        
        For II = 1 To UBound(myList, 2)
            If Not IsSheetExists(myList(1, II)) Then
                Sheets.Add(After:=Sheets(Sheets.Count)).Name = myList(1, II)
                .Rows(1).Copy Sheets(myList(1, II)).Cells(1)
            End If
            With Sheets(myList(1, II))
                myList(2, II).Copy .Range("A" & Rows.Count).End(xlUp)(2)
                .Columns(13).EntireColumn.Delete
                .Cells(1).CurrentRegion.Columns.AutoFit
            End With
        Next
    End With
End Sub

Function IsSheetExists(ByVal txt As String) As Boolean
    On Error Resume Next
    IsSheetExists = Len(Sheets(txt).Name)
    On Error GoTo 0
End Function

تقبل تحياتي

 

Purchases Follow YasserKhalil.rar