Jump to content
أوفيسنا
بحث مخصص من جوجل فى أوفيسنا
Custom Search

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


Go to solution Solved by سليم حاصبيا,

Recommended Posts

السلام  عليكم

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

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

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

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

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

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

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

Link to post
Share on other sites

تم التعديل

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

  • Like 1
Link to post
Share on other sites

السلام عليكم

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

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

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

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

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

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

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

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

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

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

Link to post
Share on other sites

بالمناسبة 

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

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

 

  • Like 1
  • Thanks 1
Link to post
Share on other sites

السلام عليكم

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

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

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

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

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

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

 

 

 

  • Like 1
Link to post
Share on other sites

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

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

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

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

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

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

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

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

1449444936_.jpg.10e8ad54ca42c6b105bfc94b4aa7096b.jpg

Link to post
Share on other sites

السلام عليكم

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

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

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

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

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

Link to post
Share on other sites
  • Solution

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

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

الملف مرفق

 

 

salim_Correction.xlsm

  • Like 1
Link to post
Share on other sites

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

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

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

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

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

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

Link to post
Share on other sites

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

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

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

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

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

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

 

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

 

Link to post
Share on other sites
13 دقائق مضت, قصي said:

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

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

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

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

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

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

 

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

 

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

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

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

 

  • Like 1
Link to post
Share on other sites

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.

Guest
Reply to this topic...

×   Pasted as rich text.   Paste as plain text instead

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

  • Recently Browsing   0 members

    No registered users viewing this page.

×
×
  • Create New...