ترحيل باختيار اعمدة معينة بدون المسلسل

[مصطفى محمود مصطفى]

السلام عليكم

هذا كود للاستاذ عبد الله باقشير جزاه الله خيرا

وهو ترحيل الناجحين ومن له دور ثاني ويكتب المسلسل تلقائيا عند كل ترحيل وهنا اريد ان الغي المسلسل عند الترحيل

وانما يقوم بترحيل البيانات المطلوبة فقط في الاعمدة والغاء كتابة المسلسل وكذلك به كود ترحيل الدور الثاني وهذا لا احتاجه في ملفي هذا 

اريد ان الغيه وحاولت ولكن يعطي رسالة خطا في كل مرة احذف الترحيل للدور الثاني من الكود

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

ولكم وافر احترامي

ترحيل باختيار اعمدة معينة بدون المسلسل.xlsb

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

الجداول في اكسل يجب ان تكون مستقلة عن اي تدخل خاجي من البيانات(دون دمج خلايا) كي يعمل اي ماكرو كما هو مبرمج

لذلك تم ادراج صف فارغ فوق الجدول في الشيت الاول والشيت الثاني

(بقي عامودين في الداتا /   تربية دينيه  و   الحالة   /  لم أعرف موقعهما لذلك قم بزيادة ارقام الاعمدة التي تناسبها  على الــ Array

                 محافظاً على الترتيب)

الكود

Option Explicit
Sub Get_najeh()
Dim s As Worksheet, T As Worksheet
Dim F_Rg As Range
Dim Ro%, Str$, My_ro, k, m
Dim Arr: Arr = Array(2, 3, 26, 35, 44, 53, 65, 82)
Set s = Sheets("الشيت"): Set T = Sheets("كشف ناجح")
T.Range("c8:N100").ClearContents
Ro = s.Cells(Rows.Count, "Di").End(3).Row
Set F_Rg = s.Range("Di12:Di" & Ro)
Str = "ناجح"
F_Rg.AutoFilter 1, Str
My_ro = s.Cells(Rows.Count, "Di").End(3).Row

m = 3
 For k = LBound(Arr) To UBound(Arr)
   s.Cells(13, Arr(k)).Resize(My_ro).Copy _
   T.Cells(8, m)
   m = m + 1
 Next
 If s.FilterMode Then
 s.ShowAllData
 F_Rg.AutoFilter
 End If
End Sub

الملف مرفق

 

My_filter.xlsm

[مصطفى محمود مصطفى]

السلام عليكم

جزاكم الله خيرا استاذ سليم

وفقكم الله ورعاكم

 

[مصطفى محمود مصطفى]

السلام عليكم استاذ سليم

استاذنا الفاضل بارك الله في جهودكم وحفظكم من كل سوء

بعد تنفيذ الكود يقوم بمسح تنسيق الجدول منC7:J24 

هل بالامكان الغاء هذا المسح من الكود 

هو ليس مهما ولكن لجمالية تنفيذ الكود بشكل صحيح

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

تحياتي لكم

تم تعديل مارس 12, 2020 بواسطه مصطفى محمود مصطفى

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

TRY THIS MACRO

FOR THE FORMATING

Option Explicit
Sub Get_najeh()
Application.ScreenUpdating = False
Dim s As Worksheet, T As Worksheet
Dim F_Rg As Range
Dim Ro%, Str$, My_ro, k, m, mmax%
Dim Arr: Arr = Array(2, 3, 26, 35, 44, 53, 65, 82)
Set s = Sheets("الشيت"): Set T = Sheets("كشف ناجح")
T.Range("b8:N100").Clear
Ro = s.Cells(Rows.Count, "Di").End(3).Row
Set F_Rg = s.Range("Di12:Di" & Ro)
Str = "ناجح"
F_Rg.AutoFilter 1, Str
My_ro = s.Cells(Rows.Count, "Di").End(3).Row

m = 3
 For k = LBound(Arr) To UBound(Arr)
   s.Cells(13, Arr(k)).Resize(My_ro - 8).SpecialCells(12).Copy
   T.Cells(8, m).PasteSpecial (xlPasteValues)
   m = m + 1
 Next
 If s.FilterMode Then
 s.ShowAllData
 F_Rg.AutoFilter
 End If
 mmax = T.Cells(Rows.Count, 3).End(3).Row
     With T.Cells(8, 2).Resize(mmax - 7, 13)
      .Borders.LineStyle = 1
      .Font.Size = 18
      .Font.Bold = True
      .InsertIndent 1
      .Columns(1).Formula = "=MAX($B$7:B7)+1"
      .Value = .Value
     End With
 T.Cells(8, 2).Select
Application.ScreenUpdating = True
End Sub

File Included

My_filter_new.xlsm

[مصطفى محمود مصطفى]

الله يبارك في علمكم وعملكم

وفقكم الله واعطاكم الصحة والعافية

استاذ سليم المبدع

 '.Columns(1).Formula = "=MAX($B$7:B7)+1"

استاذ سليم جزاكم الله خيرا

هذا السطر خاص بالمسلسل اوقفته لعدم حاجتي له

هل هناك اجراء اخر لايقاف  المسلسل  ام ينتهي بايقاف هذا الكود

لكم وافر احترامي

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

هذا السطر لادراج الترقيم (اختياري)

اذا كنت  لا تحاجه يمكن توقيفه فقط كما فعلت