مطلوب كود ترحيل بيانات من شيت الى شيتات متعددة

[ehabaf2]

السلام اعضاء الجروب الكرام

محتاج كود ترحيل بيانات الطلاب طبقا لاسم المدرسة فى شيت مستقل باسم المدرسة

مرفق الملف المطلوب 

كشف طلاب المدارس.xlsx

[ابوحبيبه]

 السلام عليكم

اتفضل اخي ... اليك الملف

كشف طلاب المدارس_1.xlsm

 

لاكمال الموضوع

عرض الكود والصور

 

[محمد هشام.]

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

Sub Unique_School()  
 
    Dim rng         As Range, cRng As Range
    Dim Cell        As Range, LstRow As Long
    Dim wsDest      As Variant, s As String
    Dim cUnique     As Collection
    Dim LrDest      As Integer, i As Integer
    Dim WorksheetExists  As Boolean
    
    Set ws_Data = ThisWorkbook.Sheets("Sheet1")
    Set rng = ws_Data.Range("C4:C" & ws_Data.Cells(ws_Data.Rows.Count, "C").End(xlUp).Row)
    Set cUnique = New Collection
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    For Each ws In Sheets
       If ws.Name <> ws_Data.Name Then ws.Delete
    Next
    On Error Resume Next
    For Each Cell In rng.Cells
        cUnique.Add Cell.Value, CStr(Cell.Value)
    Next Cell
    On Error GoTo 0
    For Each wsDest In cUnique
        s = wsDest
        Sheets.Add(After:=Sheets(Sheets.Count)).Name = wsDest
        ActiveSheet.DisplayRightToLeft = True

With ws_Data
LstRow = .Cells(.Rows.Count, "A").End(xlUp).Row
 .Range("A3").AutoFilter Field:=3, Criteria1:=wsDest
    Set cRng = .Range("A3:J" & LstRow)
     cRng.Copy Sheets(s).Range("A3")
    .Select
    .Range("A3").AutoFilter
        End With
    Next wsDest
   
   ws_Data.Activate

Application.ScreenUpdating = True
 
End Sub

كشف طلاب المدارس 2.xlsm

 

 

في حالة الرغبة باعادة انشاء تسلسل جديد للصفوف 

كشف طلاب المدارس 3.xlsm

تم تعديل يونيو 16, 2023 بواسطه Mohamed Hicham

[بلانك]

تعديل بسيط على كود استاذي / محمد اسم ورقة العمل من sheet1  to trheel

[lionheart]

Try

Sub Test()
    Const COLTARGET As Long = 3
    Dim a, ws As Worksheet, sh As Worksheet, r As Range, i As Long, n As Long
    With Application
        .ScreenUpdating = False: .EnableEvents = False: .Calculation = xlCalculationManual
    End With
        Set ws = ThisWorkbook.Worksheets("Sheet1")
        With ws.Range("A3").CurrentRegion
            Set r = .Offset(, .Columns.Count + 2).Cells(1)
            .Columns(COLTARGET).AdvancedFilter 2, , r, True
            a = r.CurrentRegion.Value: r.CurrentRegion.Clear
            For i = 2 To UBound(a, 1)
                ws.Copy After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count): Set sh = ActiveSheet: sh.Name = a(i, 1)
                sh.Range("A1").Value = a(i, 1)
                sh.Range("A3").CurrentRegion.Clear
                .AutoFilter COLTARGET, a(i, 1)
                .Copy sh.Range("A4")
                n = sh.Range("A4").CurrentRegion.Rows.Count - 1
                sh.Range("A5").Resize(n).Value = Evaluate("ROW(1:" & n & ")")
                .AutoFilter
            Next i
        End With
    With Application
        .Calculation = xlCalculationAutomatic: .EnableEvents = True: .ScreenUpdating = True
    End With
End Sub

 

[محمد هشام.]

2 ساعات مضت, بلانك said:

تعديل بسيط على كود استاذي / محمد اسم ورقة العمل من sheet1  to trheel

@بلانك لم افهم مادا تقصد 

[محمد هشام.]

@lionheart  فكره جميلة لاكن اعتقد انه من الضروري اضافة حذف الاوراق القديمة قبل تنفيذ الكود تفاديا لظهور رسالة خطأ

 With ws.Range("A3").CurrentRegion

اما بالنسبة لهدا السطر في حالة كان هناك اي بيانات اخرى بجانب الجدول (مجرد احتمال)  سيتم نسخها كدالك 

 

تم تعديل يونيو 16, 2023 بواسطه Mohamed Hicham

[بلانك]

يعطي خطأ عند التنفيذ  للكود بسبب اسم sheet1

تم تعديل يونيو 16, 2023 بواسطه بلانك

[محمد هشام.]

تمت تجرب الملف اكثر من مرة لم تظهر معي اي اخطاء اما بالنسبة  sheet1  to trheel

هدا الاسم موجود على ملف الاخ  @ابوحبيبه لم اعلم من اين اتى به لان ملف السائل يحتوي فقط على شيت باسم sheet1 وورقة لشكل النتائج المطلوبة

ممكن صورة للخطا لو سمحت

تم تعديل يونيو 16, 2023 بواسطه Mohamed Hicham

[بلانك]

بالفعل هو ملف الاستاذ/ ابوحبيبة فأنا حملته وطبقت عليه كود حضرتك وبحسب ان الملف واحد عند الاساتذه ...فعذرا منك

[محمد هشام.]

 العفو اخي حمل الملف من المرفقات ووافينا بالنتيجة

تم تعديل يونيو 16, 2023 بواسطه Mohamed Hicham

[بلانك]

لا وشكرا .... والعيب عندي انا في تحميل الملف وجزاك الله خيرا ...وعذرا منك

[sabah2022]

السلام عليكم - ممكن اعلامنا اين اضع هذا

With ws.Range("A3").CurrentRegion

[ehabaf2]

الاساتذة الافاضل الكرام

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

مجهود كبير جدا من حضراتكم و بالفعل هذا هو ما كنت اريده

الف الف شكر لحضراتكم جميعا