تعديل عى كود للترحيل

[أيسم إبراهيم]

السلام عليكم جميعا

الأساتذة الكرام

مرفق كود للترحيل به شرطين للترحيل أو د إضافة شرط ثالث و التعديل على الكود بحيث لا يتجاهل الخلايا الفارغة

المطلوب أكثر وضوحا بالمرفقات

جزاكم الله كل الخير و جعله في ميزان حسناتكم مثاقيل كثيرة

___________.rar

[عبدالله باقشير]

السلام عليكم

بكود التصفية المتقدمة:

Sub KH_START()
On Error Resume Next
Dim X As Integer
Dim MyRag As Range
Application.ScreenUpdating = False
With Sheet1
    X = .Range("A" & .Rows.Count).End(xlUp).Row
    Set MyRag = .Range("A9:CB" & X)
End With
'=================================
'     الناجحين
MyRag.AdvancedFilter Action:=xlFilterCopy _
    , CriteriaRange:=Sheet2.Range("CC1:CC2") _
    , CopyToRange:=Sheet2.Range("A9:CB9"), Unique:=False
'=================================
'     الراسبين
MyRag.AdvancedFilter Action:=xlFilterCopy _
    , CriteriaRange:=Sheet3.Range("CC1:CC2") _
    , CopyToRange:=Sheet3.Range("A9:CB9"), Unique:=False
'=================================
'     مسار اخر
MyRag.AdvancedFilter Action:=xlFilterCopy _
    , CriteriaRange:=Sheet4.Range("CC1:CC2") _
    , CopyToRange:=Sheet4.Range("A9:CB9"), Unique:=False
'=================================
Application.ScreenUpdating = True
On Error GoTo 0
End Sub

تفضل المرفق

aysam_1.rar

[أيسم إبراهيم]

السلام عليكم

أستاذنا الفاضل

جزاك الله كل الخير وفرج عنك كربات الدنيا و الآخرة

بعد مذاكرة الكود ومحاولة نقله إلى الملف الأصلى

لى بعض الاستفسارات

هل هذا الكلام صحيح؟؟؟؟؟

أعتقد أنه لابد من توافق بل توحد رؤوس الأعمدة( العناوين) في الصفحات الأربع ؟؟؟؟؟؟؟؟؟؟؟؟؟

ولابد من توحد الكلمة الموجودة في الخلية CC1 مع عنوان العمود المطلوب الترحيل بالشرط المكتوب به ؟؟؟؟؟؟؟؟؟؟

ولابد من توحد الكلمة الموجودة في الخلية CC2 مع الشرط المطلوب عليه الترحيل؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟

منتظر الرد و التوضيح

[عبدالله باقشير]

السلام عليكم

هل هذا الكلام صحيح؟؟؟؟؟

أعتقد أنه لابد من توافق بل توحد رؤوس الأعمدة( العناوين) في الصفحات الأربع ؟؟؟؟؟؟؟؟؟؟؟؟؟

ولابد من توحد الكلمة الموجودة في الخلية CC1 مع عنوان العمود المطلوب الترحيل بالشرط المكتوب به ؟؟؟؟؟؟؟؟؟؟

ولابد من توحد الكلمة الموجودة في الخلية CC2 مع الشرط المطلوب عليه الترحيل؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟

طبعا

وهو ده الحاصل في المرفق

[قصي]

السلام عليكم

بكود التصفية المتقدمة:

Sub KH_START()
On Error Resume Next
Dim X As Integer
Dim MyRag As Range
Application.ScreenUpdating = False
With Sheet1
    X = .Range("A" & .Rows.Count).End(xlUp).Row
    Set MyRag = .Range("A9:CB" & X)
End With
'=================================
'     الناجحين
MyRag.AdvancedFilter Action:=xlFilterCopy _
    , CriteriaRange:=Sheet2.Range("CC1:CC2") _
    , CopyToRange:=Sheet2.Range("A9:CB9"), Unique:=False
'=================================
'     الراسبين
MyRag.AdvancedFilter Action:=xlFilterCopy _
    , CriteriaRange:=Sheet3.Range("CC1:CC2") _
    , CopyToRange:=Sheet3.Range("A9:CB9"), Unique:=False
'=================================
'     مسار اخر
MyRag.AdvancedFilter Action:=xlFilterCopy _
    , CriteriaRange:=Sheet4.Range("CC1:CC2") _
    , CopyToRange:=Sheet4.Range("A9:CB9"), Unique:=False
'=================================
Application.ScreenUpdating = True
On Error GoTo 0
End Sub

تفضل المرفق

شكرا شكرا

جزاك الله خيرا