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

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


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





بحاجة الى كود ترحيل

السلام عليكم اخوتي اتمنى مساعدتي بكود ترحيل الاسماء بحيث يكون الترحيل حسب التسلسل مثلا تسلسل رقم 2 باسم ميسون عدنان ، ..


موضوع مغلق


13-08-2022 10:33 مساء
وليد 99999
عضو نشيط
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 30-06-2021
رقم العضوية : 22562
المشاركات : 66
الجنس : ذكر
تاريخ الميلاد : 1-1-1999
يتابعهم : 3
يتابعونه : 0
قوة السمعة : 32
 offline 

السلام عليكم 

اخوتي اتمنى مساعدتي بكود ترحيل  الاسماء  بحيث يكون الترحيل حسب التسلسل مثلا تسلسل رقم 2 باسم ميسون عدنان ، ترحل من R7 : T46 الى القائمة الفارغة التي بجانبها تبدا من A7 : C46 وتوضع امام التسلسل رقم 2 وهكذا بقية الاسماء يرحل كل اسم الى التسلسل الخاص به في  القائمة الفارغة.


 
 
  ترحيل d.xlsx   تحميل xlsx مرات التحميل :(5)
الحجم :(361.579) KB



تم تحرير الموضوع بواسطة :وليد 99999
بتاريخ:13-08-2022 10:42 مساء



أفضل إجابة مقدمة من ابراهيم الحداد وهي:
السلام عليكم ورحمة الله
تم تعديل الكود على اساس ان المقصود بالبيانات هو اسماء التلاميذ
اجعل الكود هكذا
Sub TrStuds()
Dim i As Long, C As Range
Dim Rng As Range, x As Integer
LR = Sheets("قائمة نصف السنة").Range("A" & Rows.Count).End(3).Row
Set Rng = Range("T7:T14")
x = WorksheetFunction.CountA(Rng)
If x = 0 Then
MsgBox "لا توجد اسماء لترحيلها . اكتب الاسماء اولا ثم اضغط زر ترحيل !!"
Exit Sub
End If
i = 7
Do While Range("R" & i) <> Empty

For Each C In Range("A7:A" & LR)
If C.Value = Range("R" & i) Then
C.Offset(0, 1) = Range("R" & i).Offset(0, 1)
C.Offset(0, 2) = Range("R" & i).Offset(0, 2)
End If
Next
i = i + 1
Loop
End Sub
عرض الإجابة




14-08-2022 02:46 مساء
مشاهدة مشاركة منفردة [1]
ابراهيم الحداد
خبير
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 26-08-2017
رقم العضوية : 163
المشاركات : 236
الجنس : ذكر
الدعوات : 4
يتابعهم : 0
يتابعونه : 33
قوة السمعة : 2329
عدد الإجابات: 30
 offline 
look/images/icons/i1.gif بحاجة الى كود ترحيل
السلام عليكم ورحة الله
استخدم الكود التالى
Sub TrStuds()
Dim LR As Long, i As Long, C As Range
LR = Sheets("ÞÇÆãÉ äÕÝ ÇáÓäÉ").Range("A" & Rows.Count).End(3).Row
i = 7
Do While Range("R" & i) <> Empty
For Each C In Range("A7:A" & LR)
If C.Value = Range("R" & i) Then
C.Offset(0, 1) = Range("R" & i).Offset(0, 1)
C.Offset(0, 2) = Range("R" & i).Offset(0, 2)
End If
Next
i = i + 1
Loop
End Sub

14-08-2022 10:50 مساء
مشاهدة مشاركة منفردة [2]
ابراهيم الحداد
خبير
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 26-08-2017
رقم العضوية : 163
المشاركات : 236
الجنس : ذكر
الدعوات : 4
يتابعهم : 0
يتابعونه : 33
قوة السمعة : 2329
عدد الإجابات: 30
 offline 
look/images/icons/i1.gif بحاجة الى كود ترحيل
السلام عليكم ورحمة الله
تم تعديل الكود على اساس ان المقصود بالبيانات هو اسماء التلاميذ
اجعل الكود هكذا
Sub TrStuds()
Dim i As Long, C As Range
Dim Rng As Range, x As Integer
LR = Sheets("قائمة نصف السنة").Range("A" & Rows.Count).End(3).Row
Set Rng = Range("T7:T14")
x = WorksheetFunction.CountA(Rng)
If x = 0 Then
MsgBox "لا توجد اسماء لترحيلها . اكتب الاسماء اولا ثم اضغط زر ترحيل !!"
Exit Sub
End If
i = 7
Do While Range("R" & i) <> Empty

For Each C In Range("A7:A" & LR)
If C.Value = Range("R" & i) Then
C.Offset(0, 1) = Range("R" & i).Offset(0, 1)
C.Offset(0, 2) = Range("R" & i).Offset(0, 2)
End If
Next
i = i + 1
Loop
End Sub

15-08-2022 01:56 مساء
مشاهدة مشاركة منفردة [3]
وليد 99999
عضو نشيط
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 30-06-2021
رقم العضوية : 22562
المشاركات : 66
الجنس : ذكر
تاريخ الميلاد : 1-1-1999
يتابعهم : 3
يتابعونه : 0
قوة السمعة : 32
 offline 
look/images/icons/i1.gif بحاجة الى كود ترحيل
السلام عليكم  ...جزاك الله خيرا وحفظك
 



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


 










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

الساعة الآن 03:36 مساء