يعنى اكتب البيانات بايدى كلها وفى الاخر اكتشف انك رافع ملف بيها
اتفضل الهووم وورك امستر

Sub M_Yasser()
Dim S$, r, c As Range
Set r = [A1].CurrentRegion
Set c = r(r.Columns.Count).Offset(, 3)
'.....................................
r.Columns(r.Columns.Count).AdvancedFilter 2, , c, 1

    Do While c.Offset(1).Value <> ""
        S = c.Offset(1).Value
        If Not CStr(Evaluate("ISREF('" & S & "'!A1)")) = True Then
        Worksheets.Add(, Sheets(Sheets.Count)).Name = S
1:        r.AdvancedFilter 2, c.Resize(2), Worksheets(S).Cells(1)
        c.Offset(1).Delete 2
        Else: GoTo 1
        End If
    Loop
    c.Resize(2).ClearContents
End Sub

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

Option Explicit
Sub transfer()
 Application.ScreenUpdating = False
Dim x%
Dim arr()
Dim My_String$: My_String = Sheets("Sheet1").Range("h1")
arr = Array("ناجح", "راسب", "غائب")
On Error Resume Next
Application.DisplayAlerts = False
 For x = 0 To 2
   Sheets(arr(x)).Delete
 Next
Application.DisplayAlerts = True
 On Error GoTo 0
For x = 0 To 2

  Sheets.Add(after:=Sheets(Sheets.Count)).Name = arr(x)
  Sheets("Sheet1").Cells.Copy Destination:=Sheets(arr(x)).Range("a1")
   
   With Sheets(arr(x))
    .Range("M1") = My_String
    .Range("M2") = Sheets(arr(x)).Name
    .Range("a1").CurrentRegion.AdvancedFilter Action:=1, _
     CriteriaRange:=.Range("M1:M2")
    .Range("M1:M2") = vbNullString
  End With
  Next
  Erase arr
  Sheets("Sheet1").Select
   Application.ScreenUpdating = True
End Sub

الله ينور يا رجاله حلول وابتكارات رائعه

زادكم الله علما ونفع بكم

المشاركة الأصلية كتبت بواسطة: YasserKhalil بارك الله فيكم إخواني وأحبابي في الله
حلول رائعة ومميزة ، ولا يكفي التشجيع يا حسام .. عايزين منك مشاركات فعالة لإنك خبرة بردو وعايزين نستفيد من خبراتك

المشاركة الأصلية كتبت بواسطة: YasserKhalil أخي العزيز سليم
لي عدة تحفظات في الكود ..
التحفظ الأول : المفترض أن القيم في العمود الثامن غير معروفة مسبقاً لذا لا يجوز استخدام مصفوفة لتخزين القيم بشكل مسبق
التحفظ الثاني أنك تقوم بنسخ كامل البيانات للورقة الهدف ثم عمل فلترة وترك بقية البيانات موجودة
فالهدف هو تنقيح البيانات وفصلها بشكل كامل

تقبل تحياتي

Option Explicit
Sub transfer1()
 Application.ScreenUpdating = False
Dim x%
Dim arr()
Dim last_row%
last_row = Sheets("Sheet1").Cells(Rows.Count, 1).End(3).Row
Dim FLT_rg As Range
Set FLT_rg = Sheets("Sheet1").Range("A1:H" & last_row)
Dim My_String$: My_String = Sheets("Sheet1").Range("h1")
arr = Array("ناجح", "راسب", "غائب")
On Error Resume Next
Application.DisplayAlerts = False
 For x = 0 To 2
   Sheets(arr(x)).Delete
 Next
Application.DisplayAlerts = True
 On Error GoTo 0
For x = 0 To 2

  Sheets.Add(after:=Sheets(Sheets.Count)).Name = arr(x)
  Sheets("Sheet1").Cells.Copy Destination:=Sheets(arr(x)).Range("a1")
   
   With Sheets(arr(x))
    .Range("M1") = My_String
    .Range("M2") = Sheets(arr(x)).Name
    FLT_rg.AdvancedFilter Action:=2, _
     CriteriaRange:=.Range("M1:M2"), copyTorange:=.Range("A1:H1")
  .Shapes.Range(Array("Button 1")).Delete
    .Range("M1:M2") = vbNullString
  End With
  Next
  Erase arr
  Sheets("Sheet1").Select
   Application.ScreenUpdating = True
End Sub

اخى الحبيب ياسر
دا كود بالمصفوفات ان شاء الله ينال اعجابك ويفيد الجميع

Sub Alsqr_split()
Application.ScreenUpdating = False
Dim range As Variant: Dim arr As Variant: Dim arr2 As Variant: Dim arr3 As Variant
Dim lr As Long: Dim a As Long: Dim c As Long: Dim d As Long: Dim b As Long: Dim x As Long: Dim y As Long: Dim i As Long
arrr = Array("راسب", "غائب", "ناجح")
On Error Resume Next
Application.DisplayAlerts = False
For x = 0 To 2
Sheets(arrr(x)).Delete
Next
Application.DisplayAlerts = True
lr = Sheet1.Cells(Rows.Count, 1).End(xlUp).Row
range = Sheet1.range("A1:h" & lr).Value
a = 1: c = 1: d = 1
ReDim arr(1 To UBound(range, 1), 1 To UBound(range, 2))
ReDim arr2(1 To UBound(range, 1), 1 To UBound(range, 2))
ReDim arr3(1 To UBound(range, 1), 1 To UBound(range, 2))
For i = LBound(range, 1) To UBound(range, 1)
If range(i, 8) = "راسب" Then
For b = 1 To 8
arr(a, b) = range(i, b)
Next
a = a + 1
End If
If range(i, 8) = "غائب" Then
For b = 1 To 8
arr2(c, b) = range(i, b)
Next
c = c + 1
End If
If range(i, 8) = "ناجح" Then
For b = 1 To 8
arr3(d, b) = range(i, b)
Next
d = d + 1
End If
Next
For x = 0 To 2
Sheets.Add(after:=Sheets(Sheets.Count)).Name = arrr(x)
Next
Sheets(arrr(0)).range("a1").Resize(a - 1, UBound(arr, 2)).Value = arr
Sheets(arrr(1)).range("a1").Resize(c - 1, UBound(arr2, 2)).Value = arr2
Sheets(arrr(2)).range("a1").Resize(d - 1, UBound(arr3, 2)).Value = arr3
Application.ScreenUpdating = True
End Sub

المشاركة الأصلية كتبت بواسطة: الصقر

اخى الحبيب ياسر
دا كود بالمصفوفات ان شاء الله ينال اعجابك ويفيد الجميع

CODE

Sub Alsqr_split()
Application.ScreenUpdating = False
Dim range As Variant: Dim arr As Variant: Dim arr2 As Variant: Dim arr3 As Variant
Dim lr As Long: Dim a As Long: Dim c As Long: Dim d As Long: Dim b As Long: Dim x As Long: Dim y As Long: Dim i As Long
arrr = Array("راسب", "غائب", "ناجح")
On Error Resume Next
Application.DisplayAlerts = False
For x = 0 To 2
Sheets(arrr(x)).Delete
Next
Application.DisplayAlerts = True
lr = Sheet1.Cells(Rows.Count, 1).End(xlUp).Row
range = Sheet1.range("A1:h" & lr).Value
a = 1: c = 1: d = 1
ReDim arr(1 To UBound(range, 1), 1 To UBound(range, 2))
ReDim arr2(1 To UBound(range, 1), 1 To UBound(range, 2))
ReDim arr3(1 To UBound(range, 1), 1 To UBound(range, 2))
For i = LBound(range, 1) To UBound(range, 1)
If range(i, 8) = "راسب" Then
For b = 1 To 8
arr(a, b) = range(i, b)
Next
a = a + 1
End If
If range(i, 8) = "غائب" Then
For b = 1 To 8
arr2(c, b) = range(i, b)
Next
c = c + 1
End If
If range(i, 8) = "ناجح" Then
For b = 1 To 8
arr3(d, b) = range(i, b)
Next
d = d + 1
End If
Next
For x = 0 To 2
Sheets.Add(after:=Sheets(Sheets.Count)).Name = arrr(x)
Next
Sheets(arrr(0)).range("a1").Resize(a - 1, UBound(arr, 2)).Value = arr
Sheets(arrr(1)).range("a1").Resize(c - 1, UBound(arr2, 2)).Value = arr2
Sheets(arrr(2)).range("a1").Resize(d - 1, UBound(arr3, 2)).Value = arr3
Application.ScreenUpdating = True
End Sub