استخدام كود الفلترة المتقدمهAdvanced filter

[ماجد القثمي]

أشاره الى موضوع الاستاذ ابو البراء بخصوص الفلتره المتقدمه

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

وكنت اريد فلترة الفواتير برقم الملف وبنفس طريقه الملف الذي ارفقته ولكن لم تضبط معي

 

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

وتكون الفلترة بمتغير واحد وليس متغيرين كما في ملفك

 

الداتا موجوده في شيت (Invoices)

واريد الفلتره ان تكون في الشيت (Inv.History)

وشكرا

 

Book1.rar

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

أخي الكريم ماجد

إليك الحل التالي

Sub FilterDataAccordingToDates()
    Dim WS As Worksheet, SH As Worksheet
    Dim Cell As Range, lRow As Long
    Set WS = Sheets("Invoices"): Set SH = Sheets("Inv.History")
    lRow = 5
    
    Application.ScreenUpdating = False
        SH.Range("A5:N1000").ClearContents
        For Each Cell In WS.Range("B2:B" & WS.Cells(Rows.Count, 2).End(xlUp).Row)
            If Cell.Value = SH.Range("C2").Value Then
                Cell.Offset(, -1).Resize(, 14).Copy
                SH.Cells(lRow, 1).PasteSpecial xlPasteValues
                lRow = lRow + 1
            End If
        Next Cell
        SH.Range("C2").Select
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub

تقبل تحياتي

Invoices.rar

[ماجد القثمي]

ياسلام عليك يا استاذ  ابو البراء ماشاء الله تبارك الله

 

الكود يعمل بشكل صحيح

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

 

حاولت تشغيل الكود بدون زر التفعيل فنسخت الكود  في( Private Sub Worksheet_SelectionChange(ByVal Target As Range) اصبح ياخذ وقت طويل جدا حتى ينفذ الكود حيث انه يمر على 1000 سطر للبحث

هل من الممكن تلافي هذه المشكله لان عدد الفواتير قد يصل الى اكثر من 1000

 

مع الشكر على التفاعل

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

أخي الحبيب

لا أحبذ العمل في حدث ورقة العمل في حالة البيانات الكبيرة ..لأن في حالتك Worksheet_Selection Change مع كل تحديد للخلايا سيتم تنفيذ الكود وهو أمر مرهق

أعتقد أنه من الأفضل عمل زر وربط الماكرو به تيسيراً عليك

وإذا أردت تحديث البيانات فقط اضغط الزر

أما بالنسبة لعدم استخدامي للفلترة المتقدمة فهو من باب التنوع في الحلول ولأن الفلترة تقوم بعمل نطاقات مسماة وهو ما أستحبه شخصياً

 

أمر آخر يمكنك استخدام الاستدعاء للكود باستخدام Worksheet_Change أفضل بهذا الشكل

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Cells.CountLarge > 1 Then Exit Sub
    If Not Intersect(Target, Range("C2")) Is Nothing Then
        Call FilterDataAccordingToDates
    End If
End Sub

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

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

أخي الحبيب ماجد

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

Sub CopyDataUsingArrays()
    Dim A, I As Long, II As Long, N As Long, myDate
    With Sheets("Inv.History")
        myDate = .[C2].Value
        With .[A4].CurrentRegion.Offset(1)
            .ClearContents
            A = Sheets("Invoices").Cells(1).CurrentRegion.Value
            For I = 2 To UBound(A, 1)
                If A(I, 2) = myDate Then
                    N = N + 1
                    For II = 1 To UBound(A, 2)
                        A(N, II) = A(I, II)
                    Next
                End If
            Next
            If N > 0 Then .Resize(N).Value = A
        End With
    End With
End Sub

جرب الكود وأعلمنا بالنتيجة ..جرب الكود على الملف الأصلي

تقبل تحياتي

Invoices V2.rar

[ماجد القثمي]

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

جربت الطريقتين

وكلاهما يعملان بالشكل المطلوب تماما

 

شكرا جزيلا لسعة صدرك

وجزاك الله خيرا

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

الأخ الكريم ماجد

يرجى تحديد أفضل إجابة ..

المشاركة رقم 5 أقوى 100 مرة حيث التعامل مع المصفوفات يتيح لك التعامل مع البيانات الكثيرة جداً ..دفعني إلى ذلك ذكرك أن البيانات تتعدى الـ 1000 ..يمكنك التأكد بزيادة البيانات إلى50000 مثلاً وشوف النتائج

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

لا تنسى التوجيهات

[ماجد القثمي]

فالبدايه لم الاحظ الفرق لان البيانات حاليا لا تتعدى 700

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

 

تم تحديد افضل اجابه

 

شكرا