عمل ترحيل للرقم الوظيفي مع الاسم الاول والثاني فقط

[سعد الفقير]

السلام عليكم احبتي في الله.

 

نرجوا المساعدة في حل هذة المشكلة. السؤال في الملف المرفق في الورقة الثانية . وفقكم الله

1212.rar

[ياسر خليل أبو البراء]

السلام عليكم أخي الفاضل تركي

طالما تركي ايه اللي جابك في الوطن العربي ..عموما نورت يا كبير وبين إخوانك بردو

إليك الملف التالي عله يكون المطلوب

Sub YasserKhalil()
    Dim WS As Worksheet, SH As Worksheet
    Dim LR As Long, rCell As Range
    Dim I As Long
    Dim X As Long, Y As Long
    Set WS = Sheets("السرب"): Set SH = Sheets("التمام")
    LR = WS.Cells(Rows.Count, "J").End(3).Row
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False
        SH.Range("B26:V1000").ClearContents
        With WS
            .AutoFilterMode = False
            .Range("A1:J1").AutoFilter
        End With
        
        For I = 3 To 21 Step 2
            With WS
                .Range("A1:J1").AutoFilter Field:=10, Criteria1:=SH.Cells(24, I).Value
                .Range("E1").Offset(1, 0).Resize(LR, 2).SpecialCells(xlCellTypeVisible).Copy
                SH.Cells(26, I).PasteSpecial xlPasteValues
            End With
        Next I
        
        WS.Cells.AutoFilter
    Application.CutCopyMode = False
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
End Sub

تقبل تحياتي

AutoFilter Multi Criteria YasserKhalil.rar

[سعد الفقير]

أحسنت صنعا أخي ياسر.

 

 

نعم هذا هو المطلوب ولاكن هناك مشكله في اضافة الاسم. فغالبا الاسم يكون رباعي عندما ادرجه في الورقة الاولى . انا ارغب في نقل الاسم الاول والاخير فقط في الجدول المدرج في الورقة الثانية. وشكرا لكم. 

[سعد الفقير]

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

 

With WS
            .AutoFilterMode = False
            .Range("A1:J1").AutoFilter
        End With
       
        For I = 3 To 21 Step 2
            With WS
                .Range("A1:J1").AutoFilter Field:=10, Criteria1:=SH.Cells(24, I).Value
                .Range("E1").Offset(1, 0).Resize(LR, 2).SpecialCells(xlCellTypeVisible).Copy
                SH.Cells(26, I).PasteSpecial xlPasteValues
            End With
        Next I
 

[سعد الفقير]

up

[سعد الفقير]

up

[ياسر خليل أبو البراء]

الاخ الفاضل تركي

إليك الكود مشروح بالتفصيل

Sub YasserKhalil()
    Dim WS As Worksheet, SH As Worksheet
    Dim LR As Long, rCell As Range
    Dim I As Long
    Dim X As Long, Y As Long
'تعيين أوراق العمل
    Set WS = Sheets("السرب"): Set SH = Sheets("التمام")
'تحديد رقم آخر صف به بيانات في ورقة العمل المسماة السرب
    LR = WS.Cells(Rows.Count, "K").End(3).Row
'إلغاء بعض خصائص الإكسيل
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False
'مسح محتويات النطاق الذي ستظهر فيه النتائج المطلوبة
        SH.Range("B26:V1000").ClearContents
'بدء التعامل مع ورقة العمل المسماة السرب لفلترة البيانات بها
        With WS
'إلغاء عملية الفلترة إذا كانت موجودة مسبقاً
            .AutoFilterMode = False
'فلترة نطاق الصف الأول لقاعدة البيانات
            .Range("A1:K1").AutoFilter
        End With
'حلقة تكرارية للأعمدة في ورقة العمل المسماة التمام من أول العمود الثالث وحتى العمود الحادي والعشرين
        For I = 3 To 21 Step 2
'بدء التعامل مع ورقة العمل المسماة السرب مرة أخرى للفلترة ونسخ البيانات المفلترة
            With WS
'فلترة البيانات في الحقل أو العمود رقم 11 والشرط هو أحد محتويات الصف رقم 24 في ورقة العمل التمام
                .Range("A1:K1").AutoFilter Field:=11, Criteria1:=SH.Cells(24, I).Value
'نسخ البيانات الظاهرة فقط من العمود الخامس والسادس
                .Range("E1").Offset(1, 0).Resize(LR, 2).SpecialCells(xlCellTypeVisible).Copy
'لصق البيانات التي تم نسخها إلى الصف رقم 26 في ورقة العمل التمام في العمود المناسب
                SH.Cells(26, I).PasteSpecial xlPasteValues
            End With
'الانتقال للعمود التالي في ورقة العمل التمام
        Next I
'إلغاء عملية الفلترة في ورقة العمل السرب
        WS.Cells.AutoFilter
'إلغاء خاصية النسخ والقص
    Application.CutCopyMode = False
'إعادة تفعيل خصائص الإكسيل
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
End Sub

تم التعامل مع طلبك الثاني ، متنسناش بدعوة

تقبل تحياتي

 

AutoFilter Multi Criteria YasserKhalil V2.rar

[سعد الفقير]

جزيت خيرا أخي ياسر. احسنت صنعا ما شاء الله.

[ياسر خليل أبو البراء]

أخي الفاضل لا تنسى أن تختار أفضل إجابة ليظهر الموضوع منتهي ومجاب

وإذا كان هناك طلبات أخرى فباب طرح الموضوعات مفتوح على مصراعيه

يكفي طلب واحد لكل موضوع

تقبل تحياتي

[سعد الفقير]

أخي ياسر جربت الملف الاخير وكان طلبي هو نسخ الاسم الاول والاسم الاخير فقط للموظف. ففي الملف الذي ارفقته يتم نسخ اسم الموظف الاول والثاني.

 

فهل بالامكان التعديل وكيف فعلت ذلك . بارك الله فيك وزادك من علمة. شاكرين

 

مثال اذا اسم الموظف

 

محمد خالد أحمد الحمود

ارغب في أظهار أسمه كالاتي

محمد الحمود

تم تعديل أبريل 26, 2015 بواسطه تركي١

[ياسر خليل أبو البراء]

في العمود F هتلاقي معادلة فيها رقمين 1 و 2 غيرهم وخليهم 1 و 4 .. وبعدين اسحب المعادلة لحد آخر الأسماء ، بس بشرط يكون كل الأسماء المسجلة لديك مكونة من 4

 

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

[سعد الفقير]

تم حل المشكلة جزيت خيرا. وكثر الله من أمثالك.