طلب تعديل كود ترحيل

[Mohammed Elghready]

الاخوة الكرام مبدعي هذا المنتدي الموقر لدي برنامج به صفحة للبيانات الاساسية واخري للمقبولين واخري لغير المقبولين وبحث في منتداكم الموقر عن كود للترحيل ووجدت كود للاستاذ / رجب جاويش ... واضفته بغرض ترحيل المقبولين وغير المقبولين كل في صفحة خاصة والكود يعمل ولكن في صفحة المقبولين يضيف اسم من غير المقبولين ارجوا تعديل الكود ولكم جزيل الشكر

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

استبدل في الكود ما موجود في المربع الأحمر بما بما هو موجود في المربع الأزرق

اي احذف الرقم 2 (مع ترك الفاصلة)

كما في الصورة ( في مكانين)

على كل حال ارفع الملف لاكتب لك كود بسيط جداً حوالي 10 سطور و يمكن اقل

 

 

[Mohammed Elghready]

شكرا لك استاذنا الكبير /سليم حاصبيا ... علي الرد الوافي الكافي وعلي سرعة الاستجابة  وبالنسبة للملف حجمه كبير ولم استطع رفعه ولكن حسن استجابتكم جعلتني اطمع في كود لطباعة صفحة المقبولين مع ضبط الهوامش علي ورق a4 فان كان في الاستطاعة فلكم الشكر وان لم يكن فقد كفيتم ووفيتم 

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

الكود الذي يعمل على سطر واحد يستطيع العمل على الالوف منها

لذلك ارفع ملفاُ نموذجاَ مختصراَ (دون اسماء حقيقية ) من 10 الى 15 صف لمعالحة الموضوع

 

[Mohammed Elghready]

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

الروضة2020.rar

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

جرب هذا الملف 

تم توقيف الماكروات القديمة في الملف لتقييم الماكرو (يمكنك اعادة تشغيلها)

وتصغبر جحم الملف من 8 مبغا الى 285 كيلو (اي اكثر من 25 مرة)

Mohammed.xlsm

[Mohammed Elghready]

احترامي لك استاذي العزيز سليم حاصبيا الكود يعمل بسرعة عالية عن الكود السابق.. لكن يا ريت تشرح لي الية عمل الكود لاني مش فاهمه علشان استعمله في اماكن اخري وكمان لاني اريد عدم ظهور كلمة ( مقبول وغير مقبول ) في صفحات الترحيل الكود ممتاز وسريع جدا تسلم ايديك بلغك الله من العلم المزيد وجعله في ميزان حسناتك

Sub transfer_data()
Dim D As Worksheet, sh As Worksheet
Dim Rg As Range
Dim arr(), arr_sh()
Dim i As Byte
Application.ScreenUpdating = False
arr = Array("مقبول", "غير مقبول")
arr_sh() = Array("المقبولين", "غير المقبولين")
Set D = Sheets("DATA"): Set Rg = D.Range("C5").CurrentRegion
 For i = 0 To 1
  Sheets(arr_sh(i)).Range("C5").CurrentRegion.ClearContents
  Rg.AutoFilter 8, arr(i)
  Rg.SpecialCells(12).Copy
  Sheets(arr_sh(i)).Range("c5").PasteSpecial (11)
 Next
 D.Select
 If D.AutoFilterMode Then Rg.AutoFilter
 Application.ScreenUpdating = True
End Sub

شكرا لك استاي العزيز سليم حاصبيا     ارجوا تلبية طلبي وعدم تجاهله من باب زكاة العلم

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

اذا لاحظت قمت بفصل الجدول عن بقية البيانات بواسطة صف فارغ (الصف رقم 4) عامود فارغ (العامود B)

 بهذه الطريفة يتعرّف الاكسل على  البيانات التي نريد العمل عليها بمعزل عن باقي خلايا الشيت 

و بذلك يكون الجدول مستقل عن كل شيء لا يخصّه (بيدأ من الخلية  C5 وينتهي عند احر صف غير فارغ)
بعرض 8 أعمدة من C  الى J

كل جدول في اكسل يجب ان يكون بهذه المواصفات (حدوده صف فارغ  و عامود فارغ ولا يحتوي على خلايا مدمجة)

على فكرة تم ايضا ازالة الخلايا المدمجة من النطاق F5:G5  الخلايا الصفراء

أما لماذا استعملت الخلية C5 وليس  B5 لان بكل بساطة بعد ما قمت به اصبحت الخلية  B5 فارغة

[Mohammed Elghready]

شكرا لك استاذي علي التوضيح ..... ماذا ان اردت عدم ظهور ( مقبول وغير مقبول ) في شيتات الترحيل وما معني 

 

شكرا لك استاذنا الكبير علي التوضيح الجيد .... ماذا لو اردت عدم ظهور( مقبول وغير مقبول ) في صفحات الترحيل وما معني Rg.SpecialCells(12) ارجو ان يسعني صدرك فانا اريد التعلم منك شكرا لك استاذ سليم حاصبيا

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

اذا اردت يمكنك اخفاء العامود حيث نتيجة ( مقبول   وغير مقبول )

 او يمكن عمل هذا بالماكرو كي بعطبنا فقط الأعمدة المطلوبة

الماكرو المطلوب لهذه الحالة

Option Explicit
'+++++++++++++++++++++++++++++++
Sub transfer_data_ًWithout_J()
Dim D As Worksheet
Dim Rg As Range
Dim arr(), arr_sh()
Dim i As Byte, X%
Application.ScreenUpdating = False
arr = Array("مقبول", "غير مقبول")
arr_sh() = Array("المقبولين", "غير المقبولين")
Set D = Sheets("DATA"): Set Rg = D.Range("C5").CurrentRegion
 X = D.Cells(Rows.Count, 3).End(3).Row
 For i = 0 To 1
  Sheets(arr_sh(i)).Range("C5").CurrentRegion.ClearContents
  Rg.AutoFilter 8, arr(i)
  D.Range("C5:i" & X).SpecialCells(12).Copy
  Sheets(arr_sh(i)).Range("C5").PasteSpecial (12)
 Next
 D.Select
 If D.AutoFilterMode Then Rg.AutoFilter
 Application.ScreenUpdating = True

End Sub

الملف مرفق للحالتين

 

Mohammed_New.xlsm

[Mohammed Elghready]

ما كل هذا الجمال استاذ سليم حاصبيا جعله الله في ميزان حسناتك شئ رائع حقا .. اكن لك كل احترام وتقدير 💚💯

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

اذا كان هذا ما تريد والاجالة كافية اضغط زر أفضل احابة لاغلاق الموضوع