كيف يمكن ترحيل بيانات بشكل معين فى الخلايا

[نورانور]

السلام عليكم

من فضلكم  يوجد فى الملف المرفق بيانات فى ورقة 1 اريد ترحيلها كما فى  ورقة 2  اى كل صف به بيانات فوقه صف فارغ والعدد 700 طالب وجزاكم الله خيرا

ترحيل.rar

[رجب جاويش]

تفضل أخى

Sub ragab()
Dim x As Integer, i As Integer, LR As Integer
x = 14
Sheets("ورقة2").Range("A14:CA1000").ClearContents
LR = Cells(Rows.Count, 1).End(xlUp).Row
Application.ScreenUpdating = False
For i = 13 To LR
Cells(i, 1).Resize(1, 79).Copy
Sheets("ورقة2").Range("A" & x).PasteSpecial xlPasteValues
x = x + 2
Application.CutCopyMode = False
Next
Application.ScreenUpdating = True
End Sub

ترحيل.rar

[نورانور]

شكرا للأستاذ رجب وجميع مشرفى المنتدى الكرام على سرعة الرد وبارك الله فيكم

[مجدى يونس]

الاخ رجب جاويش

كل عام وانت واعضاء المنتدى بخير

يااستاذ الترحيلات

[أبو محمد عباس]

الاستاذ والاخ الحبيب رجب جاويش بارك الله فيك وجزاك الله خيرا

جعله الله سبحانه وتعالى في ميزان حسناتك

كل عام وانتم بالف خير بلغك الله رمضان واعانك على عمل الخير

تقل فائق احترامي وتقديري

 

[أ محمد عبد الصمد]

الاستاذ الفاضل رجب جاويش

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

Sub ragab()
Dim x As Integer, i As Integer, LR As Integer
x = 14
Sheets("ورقة2").Range("A14:CA1000").ClearContents
LR = Cells(Rows.Count, 1).End(xlUp).Row
Application.ScreenUpdating = False
For i = 13 To LR
Cells(i, 1).Resize(1, 79).Copy
Sheets("ورقة2").Range("A" & x).PasteSpecial xlPasteValues
x = x + 2
Application.CutCopyMode = False
Next
Application.ScreenUpdating = True
End Sub

[رجب جاويش]

أخى الفاضل / نور

جزاك الله كل خير

[رجب جاويش]

الأستاذ الفاضل / مجدى يونس

جزاك الله كل خير على هذه الكلمات الطيبة

يا أستاذ الذوق والكلمات العطرة

[رجب جاويش]

أخى الحبيب / عباس السماوي

شكرا جزيلا أخى الحبيب على المرور العطر والكلمات الطيبة

[رجب جاويش]

أخى الفاضل / محمد

بالنسبة للكود

 

السطر التالى تعريف لبعض المتغيرات

Dim x As Integer, i As Integer, LR As Integer

السطر التالى

x = 14

يضع قيمة للمتغير X  تساوى 14 وهو أول سطر يتم لصق البيانات فى الورقة التى يتم الترحيل اليها ( ورقة 2 )

 

السطر التالى

Sheets("ورقة2").Range("A14:CA1000").ClearContents

يمسح البيانات القديمة الموجودة فى ورقة 2

 

السطر التالى

LR = Cells(Rows.Count, 1).End(xlUp).Row

يتم تحديد أخر صف يحتوى على بيانات فى الورقة المحتوية على البيانات المراد ترحيلها ووضعها داخل المتغير LR

 

السطر التالى

Application.ScreenUpdating = False

يوقف اهتزاز الشاشة

 

الجزء التالى

For i = 13 To LR

Next

حلقة تكرار من الصف 13 ( أول صف بيانات ) الى آخر صف به بيانات

 

السطر التالى

Cells(i, 1).Resize(1, 79).Copy

نسخ البيانات المكونة من صف واحد و79 عمود ( حسب البيانات )

 

السطر التالى

Sheets("ورقة2").Range("A" & x).PasteSpecial xlPasteValues

لصق البيانات فى ورقة 2

 

السطر التالى

x = x + 2

زيادة قيمة المتغير X  بمقدار 2 حتى يتم ترك صف فراغ بعد كل اسم

 

السطر التالى

Application.CutCopyMode = False

ايقاف خاصية اللنسخ واللصق

 

السطر التالى

Application.ScreenUpdating = True

ارجاع خاصية اهتزاز الشاشة كما كانت

[أ محمد عبد الصمد]

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

[رجب جاويش]

أخى الفاضل / محمد

شكرا جزيلا أخى الفاضل

وجزاك الله كل خير