مطلوب استبدال الكود بكود اسرع VBA

[ehabaf2]

السلام عليكم الاساتذة الافاضل

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

Sub Macro901()
'
' Macro901 Macro
'

'
    Range("DF4").Select
    Columns("AM:BD").AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Range( _
        "'ÇáÊÓÌíá (2)'!Criteria"), CopyToRange:=Range("'ÇáÊÓÌíá (2)'!Extract"), _
        Unique:=False
    Range("DC3:DT3").Select
End Sub
 

فهل من الممكن عمل كود VBA يقوم بعمل الكود السابق و يكون اسرع

مرفق ملف للتوضيح

الف شكر لحضراتكم

تعديل كود.xlsm

[ابا اسماعيل]

جريب هذا الكود

 

Sub FasterMacro()
    Dim wsSource As Worksheet
    Dim wsCriteria As Worksheet
    Dim wsExtract As Worksheet
    Dim sourceRange As Range
    Dim criteriaRange As Range
    Dim extractRange As Range
    
    ' تحديد ورقة المصدر
    Set wsSource = ThisWorkbook.Sheets("Sheet1") ' قم بتغيير "Sheet1" إلى اسم ورقتك
    
    ' تحديد ورقة المعايير
    Set wsCriteria = ThisWorkbook.Sheets("ÇáÊÓÌíá (2)") ' قم بتغيير اسم الورقة إذا لزم الأمر
    
    ' تحديد ورقة الاستخراج
    Set wsExtract = ThisWorkbook.Sheets("ÇáÊÓÌíá (2)") ' قم بتغيير اسم الورقة إذا لزم الأمر
    
    ' تحديد نطاق البيانات المصدر
    Set sourceRange = wsSource.Range("AM:BD")
    
    ' تحديد نطاق المعايير
    Set criteriaRange = wsCriteria.Range("'Criteria'")
    
    ' تحديد نطاق الاستخراج
    Set extractRange = wsExtract.Range("'Extract'")
    
    ' تطبيق تصفية متقدمة
    sourceRange.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=criteriaRange, CopyToRange:=extractRange, Unique:=False
    
    ' تحديد نطاق آخر (يمكن تعديله وفقًا لاحتياجاتك)
    wsSource.Range("DC3:DT3").Select
End Sub

 

تم تعديل أغسطس 14, 2023 بواسطه ابا اسماعيل

[ehabaf2]

الاستاذ الفاضل ابا اسماعيل

الف شكر لحضرتك بارك الله فيك الكود يعمل و ينفذ المطلوب

زادك الله من علمه و فضله