ترحيل بيانات حسب رقم القيد وفتح ورقة تاخذ اسمها من رقم القيد

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

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

الاساتذة الافاضل وفقكم الله

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

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

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

 

ترحيل.xlsx

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

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

قم بتغيير اسم الورقة الاولى الى Main

يجب ان يكون الجدول بشكل يغهمه الاكسل  (لا أعمدة فارغة  ) لذلك وضغت صفاً فارغاً

بحيث يبدأ الحدول من الصف رقم 3

وجرب هذا الماكرو

Option Explicit
Sub SUPER_ADV_FILTER()
Application.ScreenUpdating = False
Dim i%: i = 4
Dim arr
Dim ws As Worksheet: Set ws = Sheets("Main")
Dim rg As Object
Dim rg_to_copy As Range
Set rg_to_copy = ws.Range("a3").CurrentRegion
Set rg = CreateObject("system.collections.arraylist")
With rg
 Do Until ws.Range("d" & i) = vbNullString
  If Not .contains(UCase(ws.Range("d" & i).Value)) _
  Then .Add UCase(ws.Range("d" & i).Value)
 i = i + 1
 Loop
 For i = 0 To .Count - 1
     On Error Resume Next
   If Len(Sheets(.Item(i)).Name) = 0 Then
   Sheets.Add after:=Sheets(Sheets.Count)
    ActiveSheet.Name = .Item(i)
  End If
     On Error GoTo 0
   Next
 End With
 Set rg = Nothing
For i = 2 To Sheets.Count
  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
  Next
  Application.ScreenUpdating = True
End Sub

الملف مرفق

 

tarhil_salim.xlsm

[Ali Mohamed Ali]

أحسنت استاذ سليم كود رائع جعله الله فى ميزان حسناتك

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

الاستاذ سليم عمل اكثر من رائع جعله الله في ميزان حسناتكم

هل يمكن تعديل الكود بان يجعل لكل ورقة تسلسل يبدا من رقم 1 الى نهاية الاسماء لكل ورقة  والغاء التسلسل القديم

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

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

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

او باي شكل تراه مناسبا للتغيير المطلوب الذي ذكرته

وفقكم الله وحفظكم من كل سوء 

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

tarhil_salim1.xlsm

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

تعديل الماكرو

Option Explicit
Sub SUPER_ADV_FILTER()
Application.ScreenUpdating = False
Dim i%: i = 4
Dim y$
Dim arr
Dim ws As Worksheet: Set ws = Sheets("Main")
Dim rg As Object
Dim rg_to_copy As Range
Set rg_to_copy = ws.Range("a3").CurrentRegion

Set rg = CreateObject("system.collections.arraylist")
Dim lr%: lr = ws.Cells(Rows.Count, 1).End(3).Row
With rg
 Do Until i > lr
  If Not .contains(CLng(ws.Range("d" & i).Value)) _
   And ws.Range("d" & i).Value <> "" Then _
   .Add CLng(ws.Range("d" & 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
  Next
  Application.ScreenUpdating = True
End Sub

الملف

 

tarhil_salim_مطور.xlsm

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

الاستاذ سليم تعجز الكلمات عن شكري وتقديري لشخصكم الكريم

تبارك الرحمن , تعديل اكثر من رائع 

وفقكم الله وزادكم من فضله خيرا كثيرا

لو امكن بقى تغيير  ت في الاسماء المرحلة الى الاوراق الجديدة لو تاخذ كل ورقة تسلسل يبدا من 1 الى نهاية اسماء كل ورقة

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

ولو تعبتك معي لكني اتعشم بكم خيرا فانتم قمة في الادب والاخلاق الفاضلة

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

[وجيه شرف الدين]

جزاكم الله خير على الاضافة وشكرا كثيرا

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

نعديل على النعديل

Option Explicit
Sub SUPER_ADV_FILTER()
Application.ScreenUpdating = False
Dim i%: i = 4
Dim y$, m%, K%
Dim arr
Dim MY_Sht As Worksheet
Dim ws As Worksheet: Set ws = Sheets("Main")
Dim rg As Object
Dim rg_to_copy As Range
Set rg_to_copy = ws.Range("a3").CurrentRegion

Set rg = CreateObject("system.collections.arraylist")
Dim lr%: lr = ws.Cells(Rows.Count, 1).End(3).Row
With rg
 Do Until i > lr
  If Not .contains(CLng(ws.Range("d" & i).Value)) _
   And ws.Range("d" & i).Value <> "" Then _
   .Add CLng(ws.Range("d" & 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
  Next
  For Each MY_Sht In Sheets
    If MY_Sht.Name <> "Main" Then
     m = 4: K = 1
      Do Until MY_Sht.Range("b" & m) = vbNullString
       MY_Sht.Range("A" & m) = K
       K = K + 1: m = m + 1
      Loop
    End If
   Next
  
  Application.ScreenUpdating = True
End Sub

الملف من جديد

tarhil_salim_Moreمطور.xlsm

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

الاستاذ سليم حاصبيا  اكثر من رائع بكل شيء

وفقكم الله وحفظكم واثابكم على عملكم هذا وعلى جميع مشاركاتكم

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

اكتمل العمل وكان رائعا كروعتكم اخي الاستاذ الفاضل سليم حاصبيا

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