تجميع البيانات الى خلاصة عامة بحسب رقم الطلبية

[husas707]

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

وبارك الله فيكم وفي جميع المتعاونين في هذة المنتدى الرائع

ترحيل السلة.xlsx

[محي الدين ابو البشر]

ربما

 

ترحيل السلة.xlsm

[husas707]

شكرا لك اخي العزيز ابو بشير جعلة الله في ميزان حسناتك ياغالي

[محي الدين ابو البشر]

بارك الله

[husas707]

اخي ابو بشير هناك خطاء بسيط في الكود عندما اضع رقم الطلبية مثلا 100 وعدد اصنافها اكثر من الطلبية 102 فان الخلايا في الاعمدة من B الى E تبقى الارقام فيها ولاتنحذف عندما اختار رقم الطلبية الاقل اصناف

[محي الدين ابو البشر]

تفضل

Private Sub Worksheet_Change(ByVal Target As Range)
Dim a, No, w
Dim i&
a = Sheets("ÞÇÚÏÉ ÇáÈíÇäÇÊ").Cells(1).CurrentRegion
Application.ScreenUpdating = False
If Not Intersect(Target, Cells(1, 9)) Is Nothing Then
Me.Range(Cells(2, 2), Cells(2, 2).End(-4121).Cells).Offset(, -1).Resize(, 4).ClearContents
        With CreateObject("scripting.dictionary")
            For i = 3 To UBound(a)
                If a(i, 1) = Target.Value Then
                    If Not .Exists(a(i, 1) & a(i, 3)) Then
                        .Add (a(i, 1) & a(i, 3)), Array(a(i, 3), a(i, 4), a(i, 5), a(i, 6))
                Else
                        w = .Item(a(i, 1) & a(i, 3))
                        w(0) = w(0): w(1) = w(1) + a(i, 4)
                        w(2) = w(2) + a(i, 5): w(3) = w(3) + a(i, 6)
                        .Item(a(i, 1) & a(i, 3)) = w
                End If
            End If
Next
Me.Cells(2, 1).Resize(.Count, 4) = Application.Index(.items, 0, 0)
    End With
End If
Application.ScreenUpdating = True
End Sub

عملياً فقط تغيير

Me.Range(Cells(2, 2), Cells(2, 2).End(-4121).Cells).Offset(, -1).Resize(, 4).ClearContents

 

[husas707]

السلام عليكم

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

[محي الدين ابو البشر]

ترحيل السلة.xlsm

[husas707]

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