ترحيل من صفحة لأخرى عدى بيان واحد

[أبو يوسف النجار]

المطلوب لو تكرمتم

ترحيل جميع  البيانات الموجودة بالشيت الأول  ( ادخال البيانات ) إلى الشيت الثاني (  السجل ) ولكن بشرط عدا التلاميذ المنقولون من المدرسة وهم بالعمود ( L )  المسمى التحويل  ، ويرحل المنقول إلى  المدرسة  - بمعنى يرحل جميع البيانات عدا التلاميذ المنقولون من المدرسة - والسلام عليكم ورحمة الله وبركاته

ترحيل بشرط.rar

تم تعديل يونيو 13, 2015 بواسطه أبو يوسف النجار

[مختار حسين محمود]

  جرب الكود التالى  وهو فى المرفق

Option Explicit
Sub FilterDataCopyTo()
 
    Dim WS As Worksheet
    Dim myDate As Date
    
    Set WS = Sheets("ادخال بيانات")
   
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    With WS
        .AutoFilterMode = False
        .Range("A7:S7").AutoFilter Field:=12, Criteria1:="=محول إلى المدرسة", Operator:=xlOr, Criteria2:="="
        .UsedRange.Offset(1).SpecialCells(xlCellTypeVisible).Copy
    End With
   
    Sheets("السجل").Activate
    Range("B8").Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    Sheets("ادخال بيانات").Select
    Selection.AutoFilter
       
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    MsgBox ("المهمة انتهت بنجاج")
End Sub

ترحيل ما عدا .rar

تم تعديل يونيو 13, 2015 بواسطه مختار حسين محمود

[أبو يوسف النجار]

 

  جرب الكود التالى  وهو فى المرفق

Option Explicit
Sub FilterDataCopyTo()
 
    Dim WS As Worksheet
    Dim myDate As Date
    
    Set WS = Sheets("ادخال بيانات")
   
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    With WS
        .AutoFilterMode = False
        .Range("A7:S7").AutoFilter Field:=12, Criteria1:="=محول إلى المدرسة", Operator:=xlOr, Criteria2:="="
        .UsedRange.Offset(1).SpecialCells(xlCellTypeVisible).Copy
    End With
   
    Sheets("السجل").Activate
    Range("B8").Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    Sheets("ادخال بيانات").Select
    Selection.AutoFilter
       
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    MsgBox ("المهمة انتهت بنجاج")
End Sub

تمام أستاذ / مختار

ولكن تم الترحيل بداية من الصف 13 وليس 8

[مختار حسين محمود]

أخى الكريم  لم أجرب الكود كما ينبغى ولم أدقق فى النتائج  معذرة

Option Explicit
Sub FilterDataCopyTo()
 
    Dim WS As Worksheet
    Dim myDate As Date
    
    Set WS = Sheets("ادخال بيانات")
   
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    With WS
        .AutoFilterMode = False
        .Range("A7:S7").AutoFilter Field:=12, Criteria1:="=محول إلى المدرسة", Operator:=xlOr, Criteria2:="="
        .UsedRange.Offset(8).SpecialCells(xlCellTypeVisible).Copy
    End With
   
    Sheets("السجل").Activate
    Range("A8").Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
   Sheets("ادخال بيانات").Select
    Selection.AutoFilter
       
   Application.CutCopyMode = False
   Application.ScreenUpdating = True
   Application.DisplayAlerts = True
   MsgBox ("المهمة انتهت بنجاج")
End Sub

تحياتى

تم تعديل يونيو 14, 2015 بواسطه مختار حسين محمود

[أبو يوسف النجار]

أستاذ / مختار

لك ألف تحية - جزاكم الله خيرا

الكود ضبط تمام بارك الله فيك

[مختار حسين محمود]

الحمد لله أخى الكريم أنى وفقت لاجابة طلبك

ملحوظة صغيرة  :تعديل أخر عشان محدش يقول علينا حاجة

حذف الاعلان  Dim myDate As Date  من الكود ليس له قيمة

فأنا كنت مستعجل امبارح قبل الفجر وفى نفس الوقت أريد انهاء الكود .

أرجو من الادارة حذف الاعلان من الكود  تحياتى للجميع