أكاديمية الصقر للتدريب

لوحة التميز الأسبوعي
العضو المتميز المشرف المتميز المراقب المتميز المدير المتميز الموضوع المتميز القسم المتميز
العضو المتميز المشرف المتميز المراقب المتميز المدير المتميز الموضوع المتميز القسم المتميز
محمدعبدالسلام لا تميز خلال هذه الفترة-- لا تميز خلال هذه الفترة لا تميز خلال هذه الفترة طلب مساعدة اريد في كل 4 من شهر يتم نسح الاسم من عمود الى عمود اكسيل اسئله واجابات


أهلا وسهلا بك زائرنا الكريم في أكاديمية الصقر للتدريب، لكي تتمكن من المشاركة ومشاهدة جميع أقسام المنتدى وكافة الميزات ، يجب عليك إنشاء حساب جديد بالتسجيل بالضغط هنا أو تسجيل الدخول اضغط هنا إذا كنت عضواً .





ترحيل بيانات معينة

السلام عليكم أحبتي في المنتدى من خلال الملف المرفق أريد استنتاج حركة التلاميذ من شيت data و نقلها إلى شيت حركة التلاميذ ..


موضوع مغلق


28-02-2021 09:54 مساء
ayoub2007
عضو فعال
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 24-11-2017
رقم العضوية : 1867
المشاركات : 160
الجنس : ذكر
تاريخ الميلاد : 23-12-1970
يتابعهم : 3
يتابعونه : 1
قوة السمعة : 106
 offline 

السلام عليكم أحبتي في المنتدى
من خلال الملف المرفق أريد استنتاج حركة التلاميذ من شيت data  و نقلها إلى شيت حركة التلاميذ من خلال شهر معين ( القائمة المنسدلة في الخلية G6  شيت حركة التلاميذ)
نقل التلاميذ المعنيين للحركة الموجودة في العمودين ل و U وفقا للشهر الموجود في العمودين R  و S
توضع ملاحظات  في شيت حركة التلاميذ كالتالي :
خانة الدخول معبأة : دخول جديد
خانة الخروج معبأة : شطب
خانة الدخول  و الخروجد معبأة : تغيير الصفة
مع تحياتي لكم
 
 
 
  النتائج المتوقعة.png   تحميل png النتائج المتوقعة.png مرات التحميل :(2)
الحجم :(92.657) KB
 
  تقرير.xlsm   تحميل xlsm مرات التحميل :(7)
الحجم :(75.401) KB



أفضل إجابة مقدمة من ابراهيم الحداد وهي:
السلام عليكم ورحمة الله
استخدم هذا الكود
Sub TrnsfrData()
Dim Dta As Worksheet, ws As Worksheet
Dim Arr As Variant, Temp As Variant
Dim Rng As Range, i As Long, j As Long, p As Long
Dim StrDate As String, C As Range
Const NewInput As String = "دخول جديد"
Const Remov As String = "شطب"
Const ChngCas As String = "تغيير الصفة"

Set Dta = Sheets("data")
Set ws = Sheets("حركة التلاميذ")
T = Timer
Application.ScreenUpdating = False
ws.Range("A11:K30").ClearContents
Set Rng = Dta.Range("A7:U26")
StrDate = ws.Range("G6")
Arr = Rng.Value
ReDim Temp(1 To UBound(Arr, 1), 1 To UBound(Arr, 2))
For i = 1 To UBound(Arr, 1)
If Arr(i, 18) = StrDate Or Arr(i, 19) = StrDate Then
p = p + 1
For j = 1 To 10
Temp(p, j) = Arr(i, Choose(j, 1, 2, 3, 6, 7, 8, 9, 14, 20, 21))
Temp(p, 1) = p
Next
End If
Next
If p > 0 Then ws.Range("A11").Resize(p, UBound(Temp, 2)).Value = Temp
For Each C In ws.Range("I11:I30")
If Not IsEmpty(C) And Not IsEmpty(C.Offset(0, 1)) Then
C.Offset(0, 2) = ChngCas
ElseIf Not IsEmpty(C) Then
C.Offset(0, 2) = NewInput
ElseIf Not IsEmpty(C.Offset(0, 1)) Then
C.Offset(0, 2) = Remov
Else
C.Offset(0, 2) = Empty

End If
Next
Application.ScreenUpdating = True
MsgBox Round(Timer - T, 2)
End Sub
عرض الإجابة




01-03-2021 01:35 صباحا
مشاهدة مشاركة منفردة [1]
ابراهيم الحداد
خبير
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 26-08-2017
رقم العضوية : 163
المشاركات : 237
الجنس : ذكر
الدعوات : 4
يتابعهم : 0
يتابعونه : 34
قوة السمعة : 2349
عدد الإجابات: 31
 offline 
look/images/icons/i1.gif ترحيل بيانات معينة
السلام عليكم ورحمة الله
استخدم هذا الكود
Sub TrnsfrData()
Dim Dta As Worksheet, ws As Worksheet
Dim Arr As Variant, Temp As Variant
Dim Rng As Range, i As Long, j As Long, p As Long
Dim StrDate As String, C As Range
Const NewInput As String = "دخول جديد"
Const Remov As String = "شطب"
Const ChngCas As String = "تغيير الصفة"

Set Dta = Sheets("data")
Set ws = Sheets("حركة التلاميذ")
T = Timer
Application.ScreenUpdating = False
ws.Range("A11:K30").ClearContents
Set Rng = Dta.Range("A7:U26")
StrDate = ws.Range("G6")
Arr = Rng.Value
ReDim Temp(1 To UBound(Arr, 1), 1 To UBound(Arr, 2))
For i = 1 To UBound(Arr, 1)
If Arr(i, 18) = StrDate Or Arr(i, 19) = StrDate Then
p = p + 1
For j = 1 To 10
Temp(p, j) = Arr(i, Choose(j, 1, 2, 3, 6, 7, 8, 9, 14, 20, 21))
Temp(p, 1) = p
Next
End If
Next
If p > 0 Then ws.Range("A11").Resize(p, UBound(Temp, 2)).Value = Temp
For Each C In ws.Range("I11:I30")
If Not IsEmpty(C) And Not IsEmpty(C.Offset(0, 1)) Then
C.Offset(0, 2) = ChngCas
ElseIf Not IsEmpty(C) Then
C.Offset(0, 2) = NewInput
ElseIf Not IsEmpty(C.Offset(0, 1)) Then
C.Offset(0, 2) = Remov
Else
C.Offset(0, 2) = Empty

End If
Next
Application.ScreenUpdating = True
MsgBox Round(Timer - T, 2)
End Sub

01-03-2021 09:08 صباحا
مشاهدة مشاركة منفردة [2]
ayoub2007
عضو فعال
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 24-11-2017
رقم العضوية : 1867
المشاركات : 160
الجنس : ذكر
تاريخ الميلاد : 23-12-1970
يتابعهم : 3
يتابعونه : 1
قوة السمعة : 106
 offline 
look/images/icons/i1.gif ترحيل بيانات معينة
تمام .ألف شكر أستاذ إبراهيم الحداد مع تحياتي



الكلمات الدلالية
بيانات ، ترحيل ، معينة ،


 










اخلاء مسئولية: يخلى منتدى أكاديمية الصقر للتدريب مسئوليته عن اى مواضيع او مشاركات تندرج داخل الموقع ويحثكم على التواصل معنا ان كانت هناك اى إنتهاكات تتضمن اى انتهاك لحقوق الملكية الفكرية او الادبية لاى جهة - بالتواصل معنا من خلال نموذج مراسلة الإدارة .وسيتم اتخاذ الاجراءات اللازمة.
سياسة النشر: التعليقات المنشورة لا تعبر عن رأي منتدى أكاديمية الصقر للتدريب ولا نتحمل أي مسؤولية قانونية حيال ذلك ويتحمل كاتبها مسؤولية النشر.

الساعة الآن 05:18 صباحا