ترحيل الى أوراق متعدده

[محمد عبد القادر]

السادة الكرام لم أجد من هو أكثر منكم جوداً و فضلا فى المنتديات الأخرى جعله الله فى ميزانكم

ترحيل الى أوراق متعدده حسب المرفق

 

قاعدة بيانات اعدادى.rar

[شوقي ربيع]

السلام عليكم

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

يمكنا زيادت ما تشاء من مدارس

Sub test()
Dim sh As Worksheet, ws As Worksheet: Set sh = Feuil1
Dim lr As Long: lr = sh.Cells(sh.Rows.Count, "C").End(xlUp).Row
Dim i As Integer

For i = 2 To lr
Dim NomScol As String: NomScol = sh.Range("L" & i)
For Each ws In Worksheets
Dim NomWs As String: NomWs = ws.Name
If NomWs = NomScol Then
Set ws = Sheets(NomWs)
    Dim lrw As Long: lrw = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row + 1
    Dim r As Integer
        For r = 1 To 14
        ws.Cells(lrw, r) = sh.Cells(i, r + 2)
        Next
End If
Next ws
Next

End Sub

تحياتي

[محمد عبد القادر]

الأخ الفاضل شكرا لإهنمامك

نظهر رسالة " run time errore 424"

object required 

[شوقي ربيع]

ان كان الاوفيس عندك عربي او انجليزي غير

Dim sh As Worksheet, ws As Worksheet: Set sh = Feuil1

الى

Dim sh As Worksheet, ws As Worksheet: Set sh = Sheet1

[محمود_الشريف]

أخى فى الله

الأستاذ القدير // شوقى ربيع

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

ولى استفسار بسيط

لو اردنا الترحيل بإنشاء شيتات جديدة واسم كل شيت يؤخذ أيضا حسب البيانات التى بالعمود ( L )

فكيف يكون الكود

وتقبل منى وافر الاحترام والتقدير

[محمد عبد القادر]

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

[ا بو سليمان]

ما شاء الله تبارك الله  

[محمد ابو البـراء]

استاذ // ربيع

جزاكم الله خيراً واللسان يعجز عن الشكر

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

[رجب جاويش]

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

كل الشكر لأخى الفاضل / شوقى ربيع على هذا الإبداع

 

ولإثراء الموضوع

وكما طلب أخى الحبيب / محمود الشريف

كود لإنشاء الصفحات إن لم تكن موجودة

مع بعض الإضافات الأخرى

مثل الترحيل بنفس التنسيقات وعمل مسلسل فى الصفحات المرحل اليها

Sub ragab()
Dim cl As Range, sh As Worksheet
Application.ScreenUpdating = False
For Each sh In ThisWorkbook.Worksheets
If Not sh.Name = "Sheet1" Then
sh.Range("A2:L1000").ClearContents
End If
Next
LR = Cells(Rows.Count, 1).End(xlUp).Row
For Each cl In Range("L2:L" & LR)
x = Trim(cl.Value)
On Error Resume Next
If Worksheets(x) Is Nothing Then
Sheets.Add.Name = x
Sheets(x).Move After:=Sheets(Sheets.Count)
End If
Sheets("sheet1").Range("A1:L1").Copy
Sheets(x).Range("A1").PasteSpecial xlPasteValues
Sheets(x).Range("A1").PasteSpecial xlPasteFormats
cl.Offset(0, -11).Resize(1, 12).Copy
Sheets(x).Cells(Sheets(x).Cells(Rows.Count, 1).End(xlUp).Row + 1, 1).PasteSpecial xlPasteValues
Sheets(x).Cells(Sheets(x).Cells(Rows.Count, 1).End(xlUp).Row, 1).PasteSpecial xlPasteFormats
Sheets(x).Cells(Sheets(x).Cells(Rows.Count, 1).End(xlUp).Row, 1).PasteSpecial xlPasteColumnWidths
Sheets(x).Cells(Sheets(x).Cells(Rows.Count, 3).End(xlUp).Row, 1) = Sheets(x).Cells(Sheets(x).Cells(Rows.Count, 3).End(xlUp).Row, 1).Row - 1
Application.CutCopyMode = False
Next
MsgBox "تم الترحيل بنجاح الى صفحات منفصلة"
Sheets("sheet1").Select
Application.ScreenUpdating = False
End Sub

قاعدة بيانات اعدادى2.rar

[محمود_الشريف]

أخى فى الله

استاذى القدير // رجب جاويش

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

هذا هو المطلوب بعينه

تقبل منى وافر الاحترام والتقدير

[رجب جاويش]

أخى الحبيب / محمود الشريف

جزاك الله كل خير على هذه الكلمات الطيبة