التصفية التلقائية ونسخ الخلايا الظاهرة Autofilter & Copy Visible Cells

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

إليكم كود يقوم بعملية التصفية التلقائية Autofilter لنطاق ثم يقوم بنسخ الخلايا الظاهرة لعمود محدد ووضعها في قائمة حسب التصفية.

بفرض أن لديك بيانات في الأعمدة الثلاثة الأولى بهذا الشكل

والمطلوب توزيع الأسماء في العمود الثاني حسب اللجان في العمود الثالث ، لتكون النتائج بهذا الشكل

أي يتم إدراج كل اسم في اللجنة الخاصة به في العمود المناسب.

يعتمد الكود على عمل حلقة تكرارية للنطاق G2:J2 حيث يحتوي النطاق على أسماء اللجان المطلوب عمل تصفية للأسماء على أساسها ، وبعد عملية التصفية يتم نسخ الخلايا الظاهرة في العمود الثاني (عمود الأسماء) ولصقها في العمود المناسب حسب اسم اللجنة.

وأخيراً إليكم الكود ، ويوضع الكود في موديول عادي

Sub Autofilter_Copy_Visible_Cells()
    Dim Cel As Range

    Application.ScreenUpdating = False
        With ActiveSheet
            .Range("G3:J1000").ClearContents
    
            For Each Cel In .Range("G2:J2")
                .AutoFilterMode = False
                .Range("A1:C1").AutoFilter Field:=3, Criteria1:=Cel.Value
                .Range("B2:B" & .Cells(Rows.Count, 2).End(xlUp).Row).SpecialCells(xlCellTypeVisible).Copy
    
                .Cells(3, Cel.Column).PasteSpecial xlPasteValues
            Next Cel
            
            .AutoFilterMode = False
            Application.Goto .Range("A1")
        End With
        
        Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub

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

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