اذهب الي المحتوي
أوفيسنا

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


إذهب إلى أفضل إجابة Solved by سليم حاصبيا,

الردود الموصى بها

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

البيانات الاساسية.png

الغير مقبولين.png

المقبولين.png

الكود.png

رابط هذا التعليق
شارك

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

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

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

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

 

 

file1.png

  • Like 2
  • Thanks 1
رابط هذا التعليق
شارك

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

رابط هذا التعليق
شارك

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

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

 

رابط هذا التعليق
شارك

جرب هذا الملف 

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

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

Mohammed.xlsm

رابط هذا التعليق
شارك

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

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 أعمدة من الى J

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

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

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

  • Like 1
رابط هذا التعليق
شارك

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

 

شكرا لك استاذنا الكبير علي التوضيح الجيد .... ماذا لو اردت عدم ظهور( مقبول وغير مقبول ) في صفحات الترحيل وما معني 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

  • Like 3
رابط هذا التعليق
شارك

من فضلك سجل دخول لتتمكن من التعليق

ستتمكن من اضافه تعليقات بعد التسجيل



سجل دخولك الان
  • تصفح هذا الموضوع مؤخراً   0 اعضاء متواجدين الان

    • لايوجد اعضاء مسجلون يتصفحون هذه الصفحه
×
×
  • اضف...

Important Information