كود تصفية وتجميع

[عادل ابوزيد]

الاساتذة الكرام

مرفق ملف يحتوى على بيانات لسلع وعملاء

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

ومرفق ملف وشرح المطلوب بالشيت الثالث

تصفية وتجميع.rar

[طارق محمود]

السلام عليكم

أخي العزيز

راجع المرفق بالجداول المحورية ، أظنها الأسهل في هذه الحالة

تصفية وتجميع2.rar

[عادل ابوزيد]

استاذى القدير العزيز الغالى الباشمهندس طارق

جزاك الله كل الخير دائماً اعمالك مبدعه ومبتكرة وفيها كل جديد فى تناول المواضيع

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

العمل اضافه كبيره فى تحصيلى العلمى

وارجو ان ارى ابداعاتك فى كود يلبى طلبى

تقبل منى كل الحب والتقدير والعرفان

[عبدالله باقشير]

السلام عليكم

 

تم استخدام الكود التالي

Option Explicit

Private Const ContColmn As Integer = 3
'======================================================
'======================================================

Sub kh_Report()
Dim obj As Object
Dim x(), AryList()
Dim iKey As String
Dim iTm As Range, Rng As Range
Dim LastRow As Long, iCont As Long
Dim i As Long, ii As Long, iii As Long
Dim c As Integer
Dim v1 As Double, v2 As Double
'============================================
Set obj = CreateObject("Scripting.Dictionary")
'============================================
With Cells.Worksheet
    LastRow = .Cells(Rows.Count, "B").End(xlUp).Row
    With .Range("B4")
        .Activate
        .Resize(1, ContColmn).ClearContents
        .Offset(1, 0).Resize(LastRow, ContColmn).Clear
    End With
End With
'============================================
With ورقة2
    LastRow = .Cells(Rows.Count, "C").End(xlUp).Row
    Set Rng = .Range("C3:C" & LastRow)
End With
'============================================
On Error GoTo kh_Ex
'============================================
For Each iTm In Rng
    If CStr(iTm.Cells(1, 3)) = CStr(Range("C2")) Then
        iKey = iTm.Value
        v1 = Val(iTm.Cells(1, 4))
        v2 = Val(iTm.Cells(1, 2))
        '''''''''''''''''''
        If obj.exists(iKey) Then
            iii = obj(iKey)
            ''''''''''''''''''
            x(2, iii) = Val(x(2, iii)) + v1
            x(3, iii) = Val(x(3, iii)) + v2
        Else
            ii = ii + 1
            ReDim Preserve x(1 To ContColmn, 1 To ii)
            obj.Add iKey, ii
            ''''''''''''''''''
            x(1, ii) = iKey
            x(2, ii) = v1
            x(3, ii) = v2
        End If
    End If
Next
'============================================
iCont = obj.Count
If iCont Then
    ReDim AryList(1 To iCont, 1 To ContColmn)
    For i = 1 To iCont
        ''''''''''''''''''
        For c = 1 To 3
            AryList(i, c) = x(c, i)
        Next
        ''''''''''''''''''
    Next
    '============================================
    With Range("B4").Resize(iCont, ContColmn)
        If iCont > 1 Then .Rows(1).AutoFill .Cells, xlFillFormats
        .Value = AryList
    End With
    '''''''''''''''''''''''''
End If
'============================================

kh_Ex:
''''''''''''''''''
If Err Then
    MsgBox "Err.Number : " & Err.Number
    Err.Clear
Else
    If iCont Then MsgBox "تم تحديث التقرير بنجاح ", vbMsgBoxRight, "الحمدلله"
End If

''''''''''''''''''
Set obj = Nothing
Set Rng = Nothing
Erase x, AryList
''''''''''''''''''
End Sub

شاهد المرفق 2003

تصفية وتجميع.rar

[طارق محمود]

السلام عليكم

أخي الكريم

ضع الكود التالي في حدث الورقة 3

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address <> "$C$2" Then Exit Sub
[B4:E999].ClearContents
sel = [C2]
With Sheet2
    LR = .[C9999].End(xlUp).Row
    .Range("B2:F" & LR).AutoFilter Field:=4, Criteria1:=sel
    nLR = .[C9999].End(xlUp).Row
    .Range("C2:D" & nLR & ",F2:F" & nLR).Copy
    .AutoFilterMode = False
  End With
[B4].PasteSpecial Paste:=xlPasteValues
LR = [D9999].End(xlUp).Row
Range("D4:D" & LR).Cut
[C4].Insert Shift:=xlToRight
[A4:D4].Delete Shift:=xlUp
LR = LR - 1
If LR < 5 Then Exit Sub
For r = 4 To LR
    For nr = r + 1 To LR
        If Cells(nr, 2) = Cells(r, 2) Then
                Range("C" & nr & ":D" & nr).Copy
                Cells(r, 3).PasteSpecial Paste:=xlPasteValues, Operation:=xlAdd
                Range("B" & nr & ":D" & nr).Delete Shift:=xlUp
        End If
    Next nr
Next r
End Sub

[طارق محمود]

السلام عليكم

أخي وأستاذي الفاضل الكريم / عبدالله باقشير

الموضوع منور والله

مرورك شرف لنا جميعا

لم أر طبعا مشاركتك قبل أن أرسل

ولكن لزيادة الخير

 

أخي / عادل

الكود موجود بالمرفق أيضا

تصفية وتجميع3.rar

[عبدالله باقشير]

السلام عليكم

 

اخي الحبيب / طارق محمود  ----- حفظكم ربي

الله ينور وجهك في الدنيا والآخرة

وجزاكم خيرا

تقبلوا تحياتي وشكري

[عادل ابوزيد]

الاساتذة الكرام الافاضل

استاذى القدير العزيز عبدالله باقشير

الاستاذ القدير العزيز الباشمهندس طارق محمود

والله العظيم قلبى يرفرف فرحاً من جمال اعمالكم وسهولة التنفيذ

واسمحولى ان اطلب شرح الكود

وخصوصاً فى كود الباشمهندس طارق تم استخدام مسمى متغيريين لنفس المتغير وهما

LR = .[C9999].End(xlUp).Row

nLR = .[C9999].End(xlUp).Row

فما الفرق بين lr , nlr

ارجو من الله عز وجل ان ينير لكل بصيرتكم وقلوبكم وطريقكم ويجعل اعمالكم فى ميزان حسناتكم

[طارق محمود]

السلام عليكم
أخي العزيز

في هذا الجزء من الكود تجد أن الأمرين تقريبا مثل بعضهما

يفصل بينهما أمر تفعيل الفلتر

 

With Sheet2
    LR = .[C9999].End(xlUp).Row
     .Range("B2:F" & LR).AutoFilter Field:=4, Criteria1:=sel
     nLR = .[C9999].End(xlUp).Row
    .Range("C2:D" & nLR & ",F2:F" & nLR).Copy
    .AutoFilterMode = False
End With

 

فمجموعة الأوامر السابقة كلها ستحدث بالورقة 2 فقط With Sheet2

بعد أن يكون قد تعرف علي معيار الفلتر من الأمر السابق لهذه الأوامر وهو sel  يساوي الخلية C2

يعني يحسب رقم آخر صف LR ويستخدمه في مجال الفلتر

ثم بعد عمل الفلتر يحسب رقم آخر صف مرة أخري nLR ويستخدمه في النسخ للورقة التالية

[عادل ابوزيد]

استاذى الفاضل الكريم الباشمهندس طارق

واين الجزء الخاص بجمع الكميات والمبالغ وحذف الاسماء المكرره وكذلك ترتيب الاعمده

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

جزاكم الله كل الخير وزادكم علماً ورزقاً وسترا

[طارق محمود]

السلام عليكم

أخي الكريم

فيما يلي شرح للكود بالكامل ، أو لما لم يشرح من قبل

 

 

في أول الكود (قبل الجزء السابق شرحه) ستجد الأمر

 [B4:E999].ClearContents

والذي يمسح محتويات الخلايا B4:E999

ثم الجزء السابق شرحه والذي ينتهي بعمل نسخ من الفلتر المطلوب وإلغاء الفلتر بالورقة2

 

يأتي بعد ذلك: 

[B4].PasteSpecial Paste:=xlPasteValues
LR = [D9999].End(xlUp).Row

وهذا يجعل لصق المنسخ بداية من الخلية B4

ويحسب مرة أخري  رقم آخر صف LR لكن في الورقة Sheet3 

وسوف يستخدم هذا في ترتيب الاعمده كما ستلاحظ الأوامر التالية لذلك هي:

Range("D4:D" & LR).Cut
[C4].Insert Shift:=xlToRight

أي أنه يقطع البيانات في العمود D (الكمية) ويضعها قبل C (اجمالى السعر)

وحيث أن النسخ واللصق يأتي بصف العناوين أيضا من الورقة2 فستجد بعد ذلك الأمر

[A4:D4].Delete Shift:=xlUp
LR = LR - 1

واللذي يحذف العناوين المتكررة نتيجة النسخ بالصف 4 ثم ينقص من قيمة LR رقم1 مقابل الصف الذي تم حذفه

 

ثم بعد ذلك

If LR < 5 Then Exit Sub

وهذا لإحتمال أن نتيجة الفلتر 0 أو 1 صف فقط فلاداعي لما سيلي من الأوامر

 

 

أما الجزء الأخير فهو المسؤول عن:

(1) جمع الكميات والمبالغ وكذلك

(2) حذف الاسماء المكرره

وستجد شرحه بالصورة المرفقة

 

 

[عادل ابوزيد]

استاذى ومعلمى القدير الباشمهندس طارق

انجزت واوجزت وشرحت ففهمت

معلومات والله العظيم اول مرة اعرفها ومنها انه يمكن ترتيب ما سبق نسخه عن طريق الكود وثانياً الجمع بهذا الاسلوب

فلك منى كل التحية والحب والتقدير والدعاء فى ظهر الغيب بالصحة والستر والعافية وسعة الرزق

اللهم تقبل يا رب العالمين

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

تم تعديل سبتمبر 4, 2013 بواسطه عادل ابوزيد

[الشيباني1]

كودان رائعان من استاذين كبيرين كنت بحاجة ماسة لمثلهما ادامكما الرحمن لنا نورين ساطعين

[الشيباني1]

اساتذتنا الكرام هل بالامكان تعديل الكود ليكون البحث عن السلع مقابل الوكلاء اي ان نضع اسم الوكيل في الخليه (C2) ليتم البحث عن السلع المسحوبه من قبله   مع الامتنان

[طارق محمود]

السلام عليكم 

أخي الشيباني

تفضل ماطلبت

مع ملاحظة أن معظم العملاء ليسوا موجودين بالجدول

وأن العميل الوحيد تقريبا الذي اشتري سلعة واحدة أكثر من مرة هو العميل 5

تصفية وتجميع4.rar

[الشيباني1]

بارك الله فيكم وادامكم لنا مرجعا