اذهب الي المحتوي
أوفيسنا

الردود الموصى بها

قام بنشر (معدل)

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

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

ترحيل بشرط.rar

تم تعديل بواسطه أبو يوسف النجار
قام بنشر (معدل)

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

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

تم تعديل بواسطه مختار حسين محمود
  • Like 1
قام بنشر

 

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

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

تحياتى

تم تعديل بواسطه مختار حسين محمود
  • Like 1
قام بنشر

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

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

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

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

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

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.

زائر
اضف رد علي هذا الموضوع....

×   Pasted as rich text.   Paste as plain text instead

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

  • تصفح هذا الموضوع مؤخراً   0 اعضاء متواجدين الان

    • لايوجد اعضاء مسجلون يتصفحون هذه الصفحه
×
×
  • اضف...

Important Information