تعديل كود ترحيل البيانات حسب رقم القيد من عمود B

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

السلام  عليكم

هذا الكود للاستاذ الفاضل سليم حاصبيا جزاه الله خيرا

يقوم بترحيل البيانات حسب رقم القيد ويفتح ورقة لكل قيد باسمه اعتمادا على العمود الثاني B

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

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

ارجو التفضل بتعديل الكود ليرحل البيانات من السطر 11 بدلا من الرابع .

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

ترحيل اسماء الطلبة حسب رقم القيد.xlsm

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

تم التعديل

Option Explicit
Sub SUPER_ADV_FILTER()
'كود الاستاذ سليم حاصبيا  يقوم بترحيل الطلبة حسب رقم القيد ويفتح ورقة باسم رقم قيده
Application.ScreenUpdating = False
    Dim i%
    Dim y$, m%, K%, RO%, lr
    Dim MY_Sht As Worksheet
    Dim WS As Worksheet: Set WS = Sheets("Main")
    Dim rg As Object
    Dim rg_to_copy As Range, Ful_rg As Range

Set rg_to_copy = WS.Range("A10").CurrentRegion
Set rg = CreateObject("System.Collections.Arraylist")
lr = WS.Cells(Rows.Count, 1).End(3).Row
With rg
i = 11
 Do Until i > lr
  If Not .contains(CLng(WS.Range("b" & i).Value)) _
   And WS.Range("B" & i).Value <> "" Then _
   .Add CLng(WS.Range("B" & i).Value)
 i = i + 1
 Loop
 .Sort

 For i = 0 To .Count
     On Error Resume Next
     y = CStr(.Item(i))
   If Len(Sheets(y).Name) = 0 Then
   Sheets.Add after:=Sheets(Sheets.Count)
    ActiveSheet.Name = y
  End If
     On Error GoTo 0
   Next
 End With
 Set rg = Nothing
For i = 2 To Sheets.Count
 Sheets(i).Cells.Clear
  Sheets(i).Range("T1") = "رقم القيد"
  Sheets(i).Range("T2") = Sheets(i).Name
  rg_to_copy.AdvancedFilter 2, Sheets(i).Range("T1:T2"), Sheets(i).Range("A3")
  Sheets(i).Range("T1:T2") = vbNullString
  Set Ful_rg = Sheets(i).Range("a3").CurrentRegion
   RO = Ful_rg.Rows.Count
    If RO > 1 Then
       Sheets(i).Range("a4").Resize(RO - 1).Formula = _
      Evaluate("Row(1:" & RO - 1 & ")")
      Sheets(i).Columns("B:R").AutoFit
    End If
  Next
 '++++++++++++++++++++++++++++++++++++
 Set MY_Sht = Nothing: Set WS = Nothing
 Set rg = Nothing: Set rg_to_copy = Nothing
 Set Ful_rg = Nothing
     
 '++++++++++++++++++++++++++++++
  Application.ScreenUpdating = True
End Sub

الملف من جديد

My_tarhil.xlsm

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

الاستاذ سليم حاصبيا وفقكم الله واعطاكم الصحة والعافية

عمل اكثر من رائع

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

لكم تحياتي

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

السلام عليكم

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

حدثت مشكلة اثناء ترحيل الاسماء الى الاوراق حسب رقم القيد

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

وحاولت ان اضع بعض الاوراق باسماء تختلف عن الارقام الى جهة يمين ورقة البيانات main وابقيت على الارقام على الشمال

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

هل يمكن التعديل على الكود ان يتجاوز الاوراق التي ليس لها رقم القيد او على اليمين من قاعدة البيانات دون ان يعدل او يمسح البيانات الموجودة بداخلها

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

ان سمح لكم الوقت بذلك ويمكن التعديل على الكود 

حفظكم الباري عز وجل واعطاكم الصحة والعافية

تجاوز الاوراق غير المعنية.xlsm

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

في هذه الجزئية من الكود فقط

اجعل الحلقة التكرارية  تبدأ من الرقم  4 ( وهو رقم الصفحة الني يبدأ الكود  عمله منها)

 

 

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

بالمناسبة 

جرب تنفيذ هذا الكود و ترى العجائب

Sub ARange_sheets()
Dim t%, i%
Dim col As Object, itm
 t = Sheets("Main").Index
Set col = CreateObject("System.Collections.Arraylist")
On Error Resume Next
   For i = t + 1 To Sheets.Count
      col.Add CInt(Sheets(i).Name)
   Next
On Error GoTo 0
If col.Count Then
col.Sort: col.Reverse
   For Each itm In col
      Sheets(itm & "").Move after:=Sheets(t)
    Next
 End If
    Set col = Nothing
End Sub

 

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

السلام عليكم

استاذنا الفاضل سليم حاصبيا وفقكم الله

نسال الله سبحانه وتعالى ان لايحرمنا من لمساتك المبدعة

وفقكم الله ورزقكم الصحة والعافية وزادكم من فضله

انا غيرت الرقم حسب الشيتات الموجود مع القاعدة وهي 20 شيت اي غيرت الرقم الى 20

والكود يعمل بصورة سليمة ورائعة 

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

 

 

 

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

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

الكود اكثر من رائع وجربته ووجدت بعض الملاحظات يمكن التعديل عليها ليعمل ان شاء الله بشكل رائع كروعتكم 

الكود يعمل على تسطير الاوراق التي بعد قاعدة البيانات من اليسار من الاصغر الى الاكبر وهذا رائع

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

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

لكم شكري وتقديري

لاحظت هذا الخطأ فيما بعد وقد قمت بتصحيحه

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

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

السلام عليكم

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

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

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

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

كود استاذ سليم ترحيل حسب رقم القيد والثاني سلسلة الارقام من 1 الى الاخير.xlsm

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

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

لذلك تم ادراج صف فارغ (الصف رقم 10) لعزل الجدول والحلقة التكرارية تبدأ من الصف رقم 12

الملف مرفق

 

 

salim_Correction.xlsm

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

الله يحفظكم من كل سوء استاذ سليم

وهذه المعلومة لم انتبه لها

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

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

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

هذه المعلومة لم انتبه لها  " المهم انك تعرفها "

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

الاستاذ سليم المبدع وذو الاخلاق العالية

لا نعرف من اين نبدا بشكركم فانتم احيانا تساعدوننا

واحيانا تريدون منا ان نتعلم

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

وبمساعدتكم والاخوة الاعزاء في المنتدى الرائع ان شاء الله سنتعلم ولو القليل

دمتم في رعاية الله وحفظه

[قصي]

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

يحفظك الباري سارب

عندما ضغط على ( الزر العجايب ) وانتقلت الى الصفحه 1 ومسحتها

وكررت الضغط مره اخرى على نفس الزر

لم يحدث جديد وظل المسح كما هو

ماتعليقكم حفظكم الله ؟

 

يحفظكم الباري يارب

 

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

13 دقائق مضت, قصي said:

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

يحفظك الباري سارب

عندما ضغط على ( الزر العجايب ) وانتقلت الى الصفحه 1 ومسحتها

وكررت الضغط مره اخرى على نفس الزر

لم يحدث جديد وظل المسح كما هو

ماتعليقكم حفظكم الله ؟

 

يحفظكم الباري يارب

 

عندما ضغطت على الزر اول مرة قام البرنامج بترتيب الصفحات

واذا ضغطت مرة ثانية انت تطلب منه ان يرتبها  ، لكن هي مرتبة فعلا ولذلك لا يفعل شيئاً

جرب اعادة خربتتها بشكل عشوائي واضغط الزر وترى ما أقصده