إجمالي مرات مشاهدة الصفحة

الأربعاء، 7 سبتمبر 2016

فلترة البيانات وتصدير كل بيان حسب الفلترة إلى مصنفات جديدة Filter And Export To New Workbooks

السلام عليكم ورحمة الله وبركاته

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

مثال ليتضح المقال : بفرض أن لديك قائمة عملاء ، وأسماء العملاء مكررين ، وتريد تصدير بيانات كل عميل إلى مصنف جديد أي بيانات كل عميل تكون في مصنف مستقل

كما تلاحظون في الصورة المطلوب تصدير بيانات العملاء (محمد علي ، وفريد خان ، ومنصور السعيد ، ومنور أمين) كل عميل إلى مصنف مستقل ، ولا يشترط ترتيب البيانات في العمود ... ضع البيانات بأي شكل تريده ، والكود سيعمل بشكل ممتاز ليؤدي المطلوب إن شاء الله

في الكود تقوم بتحديد رقم أول عمود وهو هنا في المثال 1 أي العمود A ، كما نقوم بتحديد رقم آخر عمود وهو هنا 4 أي العمود D
كما تقوم بتحديد العمود الذي ستقوم بفلترة البيانات فيه وهو هنا عمود العملاء ألا وهو رقم 1
كما تقوم بتحديد اسم ورقة العمل المطلوب العمل عليها ، وهي ورقة العمل Sheet1

وأخيراً إليكم الكود الذي يؤدي المهمة (تصدير بيانات من نفس القيمة لمصنفات جديدة ، حيث يتم تصدير البيانات في نفس مسار المصنف الحالي في مجلد اسمه Output)

Sub Export_Workbooks_Using_Filter()
'Author  : YasserKhalil
'Release : 07 - 09 - 2016
'------------------------
    Dim a           As Variant
    Dim I           As Long
    Dim P           As Integer
    Dim cnt         As Integer
    Dim Dic         As Object
    Dim strDir      As String
    Dim Arr()       As Double
    Dim iFlag       As Boolean

    '=========================================================
    Const firstCol  As Long = 1             'First Column
    Const lastCol   As Long = 4             'Last Column
    Const colNo     As Long = 1             'Column To Filter
    Const sSheet    As String = "Sheet1"    'Sheet Name
    '=========================================================

    strDir = ThisWorkbook.Path & "\Output\"
    For P = firstCol To lastCol
        ReDim Preserve Arr(P - 1)
        Arr(P - 1) = Sheets(sSheet).Columns(P).ColumnWidth
    Next P
    iFlag = Sheets(sSheet).DisplayRightToLeft

    Call SpeedUp
        If Dir(strDir, vbDirectory) = "" Then MkDir strDir
    
        Sheets.Add before:=Sheets(1)
        Set Dic = CreateObject("Scripting.Dictionary")
        Dic.CompareMOde = 1
    
        With Sheets(sSheet).[A1].CurrentRegion
            .Columns(colNo).Value = Application.Trim(.Columns(colNo).Value)
            a = .Value
            .Parent.AutoFilterMode = False
    
            For I = 2 To UBound(a, 1)
                If Not Dic.exists(a(I, colNo)) And Not IsEmpty(a(I, colNo)) Then
                    Dic(a(I, colNo)) = Empty
                    .AutoFilter colNo, a(I, colNo)
                    .Copy Sheets(1).Cells(1)
                    Sheets(1).Copy
    
                    With ActiveWorkbook
                        With Sheets(1)
                            .Name = "Sheet1"
                            .DisplayRightToLeft = iFlag
                            .Cells(1).CurrentRegion.RowHeight = 19
                            For cnt = firstCol To lastCol
                                .Columns(cnt).ColumnWidth = Arr(cnt - 1)
                            Next cnt
                        End With
    
                        .SaveAs strDir & RemoveSpecial(CStr(a(I, colNo))) & ".xlsx"
                        .Close
                    End With
    
                    Sheets(1).Cells.Clear
                    .AutoFilter
                End If
            Next I
        End With
    
        Sheets(1).Delete
    Call SpeedDown

    MsgBox "Done...", 64
End Sub

Function RemoveSpecial(sInput As String) As String
    Dim sSpecialChars   As String
    Dim I               As Long

    sSpecialChars = "\/:*?""<>|"
    For I = 1 To Len(sSpecialChars)
        sInput = VBA.Trim(Replace$(sInput, Mid$(sSpecialChars, I, 1), " "))
    Next I

    RemoveSpecial = sInput
End Function

Function SpeedUp()
    With Application
        .Calculation = xlManual
        .ScreenUpdating = False
        .DisplayAlerts = False
        .EnableEvents = False
    End With
End Function

Function SpeedDown()
    With Application
        .Calculation = xlAutomatic
        .ScreenUpdating = True
        .DisplayAlerts = True
        .EnableEvents = True
    End With
End Function

إعداد / ياسر خليل أبو البراء

هناك 11 تعليقًا:

  1. اقر انا الموقع ادناه بان الاستاذ : ياسر خليل ( ظاهرة ابداعيه .. تدرس )
    حسن علي

    ردحذف
  2. ربنا يبارك فيك يا قبطان ويجازيك خير
    نورت المدونة بمرورك الندي

    ردحذف
  3. جزيت خيراً أخي الكريم ، والإبداع أنتم مجشعوه

    ردحذف
  4. اخى ياسر
    ابداع بسم الله ما شاء الله

    ردحذف
  5. جزاكم الله خيراً أخي الكريم سعد عابد ونورت المدونة بتعليقك الجميل

    ردحذف
  6. جزاك الله خيرا
    رغم أنى أغبط الاكسل عليك ورجوت لو تحولت للأكسس حتى لو بعض الوقت
    محبكم فى الله - أحد أعضاء أوفيسنا

    ردحذف
  7. أخي الكريم المراد
    أخي الكريم السيد
    أخي الكريم أبو عبد الله
    بارك الله فيكم ونورتم المدونة بمروركم العطر ، والإكسيل والأكسس ولاد عم مبعدناش كتير
    تقبلوا تحياتي

    ردحذف
  8. بارك الله فيك اخي الكريم ... ورحم الله والديك

    ردحذف