ترحيل بيانات بشرط

[scorpionehb]

السلام عليكم ورحمة الله وبركاته

الرجاء من سيادتكم

طريقة ترحيل بيانات الصف من شيت الى الاخر بشرط وجود الاسم

بمعنى هذه اسماء اكتر من 500 اسم

المطلوب ترحيل الرقم القومى والكود  الى شيت اخر بمجرد كتابه اسم الطالب بدون ترتيب

سوف استخلص منهم مجموعات معينه ممكن ان تكون 30 اسم او 50 اى  عدد

هذه المجموعات اسماء فقط اريد عند وضع هذه الاسماء المختارة فى شيت يتم ترحيل بيانات الاسم من الشيت الأصلى الى الشيت الجديد

تــــم رفــع الملــف

كشف مناداه جديد.xls

[سليم حاصبيا]

جرب هذا الكود

تحتار   من   الى  من حلال الخلايا  L2  و  K2 تم تضغط الزر Run الصفحة  (My_shee

لاختيار اسم واحد تضع الخلايا    L2  و  K2   متساوتين

مثلا من 10 الى 10 تعطيك السجل رقم 10

Sub Get_Dta()

Dim M As Worksheet, T As Worksheet
Dim LrM%, i%, Mn, Mx, k%
Set M = Main: Set T = Targ
LrM = M.Cells(Rows.Count, 1).End(3).Row
T.Range("A2").Resize(LrM, 8).ClearContents
If Val(T.Cells(2, "L")) < 2 _
 Or T.Cells(2, "L") > LrM Then T.Cells(2, "L") = 2
 If Val(T.Cells(2, "K")) < 2 _
 Or T.Cells(2, "K") > LrM Then T.Cells(2, "K") = T.Cells(2, "L") + 10
  Mn = Application.Min(T.Cells(2, "K"), T.Cells(2, "L"))
  Mx = Application.Max(T.Cells(2, "K"), T.Cells(2, "L"))
  T.Cells(2, "K") = Mx
  T.Cells(2, "L") = Mn
 T.Cells(2, 2).Resize(Mx - Mn + 1, 7).Value = _
 M.Cells(Mn, 1).Resize(Mx - Mn + 1, 7).Value
 
 '+++++++++++++++By Choise++++++++++++++++++++++++
' T.Cells(2, 1).Resize(Mx - Mn + 1).Value = _
' Evaluate("Row(1:" & Mx - Mn + 1 & ")")

 T.Cells(2, 1).Resize(Mx - Mn + 1).Value = _
 Evaluate("Row(" & Mn & ":" & Mx & ")")
 '+++++++++++++++++++++++++++++++++++++++++++++++++
End Sub

الملف مرفق

scorpionehb.xlsm

[مدحت حافظ]

كود رائع جدا استاذ سليم بارك الله فيك وجزاك كل خير