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

الأربعاء، 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

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

الثلاثاء، 6 سبتمبر 2016

تقسيم أو شطر قائمة واحدة إلى قائمتين بالتساوي Split List In Two Lists Equally

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




أقدم لكم موضوع جديد ألا وهو تقسيم أو شطر قائمة واحدة إلى قائمتين بالتساوي

بفرض أن لديك قائمة بأسماء التلاميذ وليكن عدد التلاميذ 23 وتريد تقسيم القائمة أي شطرها إلى نصفين .. في الشطر الأيمن 12 طالب وفي الأيسر 11 طالب (الكود مرن ويتعامل مع أي عدد من الأسماء أو البيانات)

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

إليكم الكود ... يقوم الكود بتقسيم القائمة إلى شطرين بالبيانات الملحقة بها وتظهر النتائج في ورقة العمل الثانية Sheet2

Sub SplitList()
'Author  : YasserKhalil
'Release : 07 - 09 - 2016
'------------------------
    'تعريف المتغيرات
    Dim shSource As Worksheet, shTarget As Worksheet
    Dim rList As Range, rListA As Range, rListB As Range
    Dim hCount As Long, tCount As Long
    
    'عدد أعمدة النطاق المراد عمل إنشطار له
    Const colNum As Integer = 3
    
    'تعيين ورقة العمل المصدر التي تحتوي القائمة الرئيسية وورقة العمل الهدف
    Set shSource = Sheets("Sheet1")
    Set shTarget = Sheets("Sheet2")
    
    'تعيين النطاق الذي يحتوي على القائمة المراد شطرها
    Set rList = shSource.Range("A6:A" & shSource.Cells(Rows.Count, "A").End(xlUp).Row)
    
    'تعيين بداية النطاق للشطر الأول من القائمة
    Set rListA = shTarget.Range("A4")
    
    'تعيين بداية النطاق للشطر الثاني من القائمة
    Set rListB = rListA.Offset(, colNum)
    
    'تعيين قيمة المتغير ليساوي عدد خلايا النطاق المصدر
    tCount = rList.Cells.Count
    
    'تعيين قيمة للمتغير ليساوي تقريب قيمة قسمة المتغير السابق ÷ 2
    hCount = Application.RoundUp(tCount / 2, 0)

    'مسح النطاق الذي ستظهر فيه النتائج للشطر الأول والشطر الثاني
    shTarget.Range("A3").CurrentRegion.Offset(1).ClearContents
    
    'وضع نتائج الشطر الأول
    rListA.Resize(hCount, colNum).Value = Range(rList(1).Address(External:=True) & ":" & rList(hCount).Address(External:=True)).Resize(hCount, colNum).Value
    
    'وضع نتائج الشطر الثاني
    rListB.Resize(tCount - hCount, colNum).Value = Range(rList(hCount + 1).Address(External:=True) & ":" & rList(tCount).Address(External:=True)).Resize(hCount, colNum).Value
    
    MsgBox "Done ..." & vbNewLine & "Best Regards" & Chr(10) & "YasserKhalil", 64
End Sub

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