انشاء كود فلترة و انشاء شيت جديد للبيانات

[Ahmed Saad 2017]

السادة الزملاء المحترمين برجاء المساعدة في انشاء كود فلترة و انشاء شيت جديد للبيانات بحيث انه يتم عمل فلتر علي العمود  A ثم يتم انشاء جديد وليس تاب بأسم الرو و ترحيل الداتا المفلترة الي الشيت الجديد 

مرفق الشيت 

Copy of New Microsoft Excel Worksheet (13).xlsx

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

حرب هذا الكود

يأخذ وقتاً بعض الشيء لان البيانات كثيرة حوالي 20 الف صف مع خلق صفحات جديدة اذا لم تكن موجودة مسبقاً

Option Explicit
Sub Get_More_sheets()
Dim my_arr()
Dim LrMM%, i%, x%
  Application.ScreenUpdating = False
 With Sheets("Sheet1")
  If .FilterMode Then
   .ShowAllData
   .Range("a1").AutoFilter
   End If
 End With
Sheets("Sheet1").Range("a2", Range("a1").End(4)).Copy _
Sheets("Sheet1").Range("MM1")
LrMM = Cells(Rows.Count, "MM").End(3).Row
Sheets("Sheet1").Range("MM1:MM" & LrMM). _
RemoveDuplicates Columns:=1
LrMM = Cells(Rows.Count, "MM").End(3).Row
 ReDim my_arr(1 To LrMM)
  For i = 1 To LrMM
   my_arr(i) = Range("MM" & i)
   Next
  Sheets("Sheet1").Range("MM1:MM" & LrMM).Clear
  On Error Resume Next
   For i = 1 To LrMM
   x = Len(Sheets(my_arr(i)).Name)
   If x = 0 Then
   Sheets.Add(After:=Sheets(Sheets.Count)).Name = my_arr(i)
   End If
   Next
   Sheets("sheet1").Activate
   On Error GoTo 0
  For i = 1 To LrMM
      With Sheets("Sheet1").Range("a1").CurrentRegion
.AutoFilter Field:=1, Criteria1:=my_arr(i)
.SpecialCells(12).Copy _
   Sheets(my_arr(i)).Range("A1")
   Sheets(my_arr(i)).Columns("A:B").AutoFit
    End With
  Next
  
  With Sheets("Sheet1")
      If .FilterMode Then
       .ShowAllData
       .Range("a1").AutoFilter
      End If
  End With
  MsgBox "That Is All" & Chr(10) & _
  "Thank You ====> Salim"
  Application.ScreenUpdating = True
End Sub

الملف مرفق

GET_sheets.xlsm

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

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

[Ahmed Saad 2017]

بشكر حضرتك علي المساعدة بس انا محتاج ان الكود ينشأ ملف عمل جديد بأسم الفلتر و ليس شيت جديد في ورقة العمل  فبرجاء لو في حل آخر تساعدنا بيه 

 

Copy of New Microsoft Excel Worksheet (13).xlsx