انشطار البيانات باستخدام الفلترة Split Data Using Filter Method

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

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

بفرض أن لديك ورقة عمل باسم Data وبها بيانات بهذا الشكل :

والمطلوب إنشاء أوراق جديدة للبيانات بناءً على فلترة عمود محدد ، على سبيل المثال العمود الخامس يحتوي على إما Pass أو Fail (يفيد في فصل الناجحين والراسبين) .. عند تنفيذ الكود يظهر صندوق إدخال لتحديد رقم العمود المطلوب الفلترة على أساسه وهو هنا كما في المثال العمود الخامس ، لذا نكتب رقم 5 في صندوق الإدخال.

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

 إذا كان التصدير لمصنف جديد يتم تسمية المصنف الجديد باسم Filtered ويكون الحفظ للمصنف في نفس مسار المصنف الحالي.

أما إذا اخترت الخيار "لا" يتم إنشاء أوراق العمل في نفس المصنف الحالي ، بعد حذف أوراق العمل التي لها نفس الاسم لتجنب الأخطاء.

الكود المستخدم في الملف المرفق بالشكل التالي :

 Sub SplitFilteredData()
    Dim mySheet As Worksheet
    Dim myRange As Range
    Dim uList As Collection
    Dim uListValue As Variant
    Dim I As Long
    Dim J As Long
    Dim myCol As Long
    Dim WB As Workbook
    Dim Arr()
    
    Application.ScreenUpdating = False
        Set mySheet = ThisWorkbook.Sheets("Data")
        myCol = Application.InputBox(Prompt:="Enter Column Number You Need To Filter", Type:=1)
        
        If mySheet.AutoFilterMode = False Then
            mySheet.UsedRange.AutoFilter
        End If
        
        If myCol > mySheet.AutoFilter.Range.Rows(1).SpecialCells(xlCellTypeVisible).Count Or myCol < 1 Or Not IsNumeric(myCol) Then
            MsgBox "You Should Enter Between 1 And " & mySheet.AutoFilter.Range.Rows(1).SpecialCells(xlCellTypeVisible).Count: mySheet.UsedRange.AutoFilter: Exit Sub
        End If
        
        Set myRange = Range(mySheet.AutoFilter.Range.Columns(myCol).Address)
        Set uList = New Collection
        
        For J = 1 To mySheet.UsedRange.Columns.Count
            ReDim Preserve Arr(1 To J)
            Arr(J) = mySheet.Columns(J).ColumnWidth
        Next J
        
        On Error Resume Next
            For I = 2 To myRange.Rows.Count
                If Not IsEmpty(myRange.Cells(I, 1)) Then
                    uList.Add myRange.Cells(I, 1), CStr(myRange.Cells(I, 1))
                End If
            Next I
        On Error GoTo 0
        
        If MsgBox("Do You Need To Export Results To New Workbook?" & vbNewLine & "Click 'Yes' To Export To New Workbook" & Chr(10) & "Click 'No' To Get The Results In This Workbook", vbYesNo) = vbYes Then
            Set WB = Workbooks.Add
        Else
            Set WB = ThisWorkbook
        End If
        
        For Each uListValue In uList
            On Error Resume Next
                Application.DisplayAlerts = False
                Sheets(CStr(uListValue)).Delete
                Application.DisplayAlerts = True
            On Error GoTo 0
            
            myRange.AutoFilter Field:=myCol, Criteria1:=uListValue
            mySheet.AutoFilter.Range.Copy
            WB.Worksheets.Add.Paste
            
            With ActiveSheet
                .Name = Left(uListValue, 30)
                .DisplayRightToLeft = False
                .Cells.RowHeight = 19
                For J = 1 To .UsedRange.Columns.Count
                    .Columns(J).ColumnWidth = Arr(J)
                Next J
                
                Application.Goto .Range("A1")
            End With
        Next uListValue
        
        Application.DisplayAlerts = False
            If WB.Name <> ThisWorkbook.Name Then
                WB.Sheets("Sheet1").Delete
                WB.SaveAs Filename:=ThisWorkbook.Path & "\Filtered" & ".xlsx"
                WB.Close True
            End If
        Application.DisplayAlerts = True
        
        mySheet.Cells.AutoFilter
        Application.CutCopyMode = False
        Application.Goto mySheet.Range("A1")
    Application.ScreenUpdating = True
    
    MsgBox "Done...", 64
End Sub  

تحميل الملف من هنا

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