يوسف عطا

الكود كامل بشرحه التفصيلى علماً بأنه تم عمل معادلة فى العمود الخامس لتحديد القسم الذى سيرحل إليه الطالب حسب المواد التى سيدرسها Sub ترحيل_أقسام() ''' متغيرات بعدد الصفحات المطلوب الترحيل اليها Dim R As Integer, A As Integer, B As Integer, C As Integer, D As Integer ''' أسماء الصفحات المطلوب الترحيل اليها والمدى المطلوب مسح البيانات القديمة منه Sheets("أدبى").Range("A2:DZ5000").ClearContents Sheets("أدبى محول").Range("A2:DZ5000").ClearContents Sheets("علمى علوم").Range("A2:DZ5000").ClearContents Sheets("علمى رياضة").Range("A2:DZ5000").ClearContents ''' عدد الصفوف العليا في الصفحات المنقول اليها البيانات A = 2: B = 2: C = 2: D = 2 Application.ScreenUpdating = False ''' بداية ونهاية صفوف الورقة المصدر For R = 2 To 5000 ''''''''''''''''''''''''''''''''''''''''''''''''''' ''تكرر الأسطر التالية لكل شيت يتم الترحيل فيه مع تغيير المتغيرات ''' رقم عمود المعيار وكلمة المعيار If Cells(R, 5) = "أدبى" Then ''' عدد الأعمدة التى سيتم ترحيلها Range("A" & R).Resize(1, 11).Copy ''' سيتم اللصق في هذا الشيت Sheets("أدبى").Range("A" & A).PasteSpecial xlPasteValues Application.CutCopyMode = False A = A + 1 End If If Cells(R, 5) = "أدبى محول" Then Range("A" & R).Resize(1, 11).Copy Sheets("أدبى محول").Range("A" & B).PasteSpecial xlPasteValues Application.CutCopyMode = False B = B + 1 End If If Cells(R, 5) = "علمى علوم" Then Range("A" & R).Resize(1, 11).Copy Sheets("علمى علوم").Range("A" & C).PasteSpecial xlPasteValues Application.CutCopyMode = False C = C + 1 End If If Cells(R, 5) = "علمى رياضة" Then Range("A" & R).Resize(1, 11).Copy Sheets("علمى رياضة").Range("A" & D).PasteSpecial xlPasteValues Application.CutCopyMode = False D = D + 1 End If 'If Cells(R, 4) = "5" Then 'Range("A" & R).Resize(1, 11).Copy 'Sheets("5").Range("A" & E).PasteSpecial xlPasteValues 'Application.CutCopyMode = False 'E = E + 1 ' End If 'If Cells(R, 4) = "6" Then 'Range("A" & R).Resize(1, 11).Copy 'Sheets("6").Range("A" & F).PasteSpecial xlPasteValues 'Application.CutCopyMode = False 'F = F + 1 ' End If Next For J = 1 To 4 Sheets(J).[a2] = 1 rrw = Sheets(J).[B3000].End(xlUp).Row For Each cc In Sheets(J).Range("a3:B" & rrw) cc.Value = cc.Offset(-1, 0) + 1 Next cc Next J MsgBox ("الحمد لله تـــم ترحيل الطلبة كل إلى قسمه") For k = 1 To 4 y = Sheets(k).[B3000].End(xlUp).Row - 1 mssg = mssg & Chr(10) & Format(y, "00") & " Students to Sheet : " & k Next k MsgBox (" تم ترحيل عدد" & mssg) Range("B1").Select Application.ScreenUpdating = True End Sub

الكود فى الملف يقوم بترحيل 9 أعمدة فقط لزيادة عدد الأعمدة يتم تغيير هذا الجزء من الكود الذى يتكرر فى كل شيت ترحيل Range("A" & R).Resize(1, 9).Copy ليكون هكذا فى كل ترحيلة أى ينبغى تغييره 4 مرات فى حالة هذا الملف Range("A" & R).Resize(1, 11).Copy تغيير الرقم 11 يغير عدد الأعمدة التى يتم ترحيلها فى كل شيت

تفضل يا الغالى وأعتذر عن التأخير لإنقطاع الكهرباء هذا الملف يقوم بالتالى 1. تغيير قسم الطالب بمجرد تغيير المادة صاحبة شرط الدخول للقسم 2. يقوم بعمل مسلسل لكل قسم 3. يقوم بإخراج إحصاء لكل قسم 4. يقوم تلقائياً بمسح الترحيلات السابقة عند الضغط على زر الترحيل مرة أخرى حتى لا تتراكم الداتا تحت بعضها صف ثالث.rar

عفواً لم أنتبه لحالة تغيير المواد جارى التعديل على الملف مرة أخرى

جرب المرفق ملحوظة قبل الضغط على زر الترحيل لابد من مسح البيانات القديمة بالضغط على زر مسح فى كل شيت خاص بقسم تم تغيير مسميات الشيت لعمل الكود صف ثالث.rar

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

تفضلى eeeee.rar

رجاء شرح المشكلة بإختصار فى المشاركة

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

أخى الغالى محمود بك اشكرك لأنك نورت مخى بفكرتك وبعد تعديل بسيط فيها تم إنجاز المطلوب والكود الذى إستخدمته وقام بالمهمة مظبوط هو كالتالى ()طبع_الأولىSub Range("B8:S50").Select ActiveSheet.PageSetup.PrintArea = "$B$8:$S$22" Activewindow.SelectedSheets.PrintPreview Activewindow.SelectedSheets.PrintOut Copies:=1, Collate:=True Range("K3").Select End Sub

أخى الغالى محمود بك أشكرك لتفاعلك مع الموضوع ومحاولة حل المشكلة ولكن هذا الحل لا يصلح لأنى لا أريد مسح أو حذف الشهادتين الأخريتين بل أريد أن يتم طباعة البرنت إيريا المحددة للشهادة العلوية فقط ولكن أريدها أن تكون فى الجزء العلوى من ورقة الطباعة وقد إستخدمت الكود التالى وكانت الشهادة تطبع فى وسط الورقة طبع_الأولى()Sub Range("B8:S22").Select Selection.PrintOut Copies:=1, Collate:=True Range("k3").Select End Sub علماً بأن كل شهادة تتكون من 14 سطر وشيت ال3 شهادات يبدأ من الخلية B8 إلى الخلية S50

عند طبع الشهادات تقوم الطابعة بطبع 3 شهادات فى الشيت قمت بتعديل الكود ليطبع شهادة واحدة فقط وقام بالفعل بطباعة الشهادة المحددة ولكن قامت الطابعة بطبع الشهادة المذكورة فى وسط الصفحة رغم أن الشهادة المحدد طباعتها كانت الشهادة العلوية أى المفروض أن تطبع فى الثلث العلوى من الورقة ما الحل لكى تقوم الطابعة بطبع الشهادة المحددة فى الجزء العلوى من الصفحة

حدد العمود الذى ستكتب فيه أرقام الموبايلات كليك يمين تنسيق خلايا من علامات التبويب فى الأعلى إختار رقم من الخيارات الجانبية إختار مخصص فى المستطيل تحت كلمة النوع أكتب أحدعشر صفراً ثم موافق أى رقم ستكتبه فى هذا العمودأقل من 11 رقم سيستكمله الإيكسيل باصفار على اليسار ليصبح 11 رقم فلو كتبت 5 أرقام سيضع الإيكسيل 6 أصفار على يسارهم ولو كتبت 11 رقم سيكتبهم الإيكسيل بالضبط كما تكتبهم ولو كتبت أكثر من 15 رقم سيقوم الإيكسيل بكتابة 15 رقم والزيادة سيكتبها أصفار على اليمين ولتصحيح هذا وزيادة عدد الأرقام فى الخلية تحتاج حل آخر والله أعلم مرفق الصورة Uploaded with ImageShack.us

الملف بتاعك فيه مشكلة الرجاء إعادة رفعه وياريت تعطينا فكرة عن الموضوع الذى تريده فى المشاركة نفسها حتى يتيسر معرفة المطلوب قبل تنزيل الملف

الف شكر يا الغالى ولكنى وجدتها بإسم شريط قوائم التخطيط وليس شريط قوائم ورقة العمل أو الووركشيت ولذلك لم أعتقد أنها هى المقصودة والف شكر ومنكم نستفيد Uploaded with ImageShack.us

حاولت بعدة طرق ولم استطع الرجاء المساعدة

موضوع مفيد جداً ومعلومات أعرفها لأول مرة رغم إنى بستخدم الإيكسيل منذ 20 سنة

مثال عن كود حذف ضع مكان XX:XX المدى المطلوب مسحه أول خلية وآخر خلية فى المدى Sub مسح() Range("xx:xx").Select Selection.ClearContents End Sub

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

أستاذى العزيز أحمد بك حمور كيف اضيف أوراق جديدة فى الملف وتظهر أسمائها فى ويندو الصلاحيات لكل مستخدم ؟؟

الشكر الجزيل للأخ الأستاذ أحمد حمور على هذا الملف الرائع والشكر للأخوة نيكولا وابو علاء لإعادة التفاعل للموضوع بعد أن ظل عدة شهور بدون تفاعل ربنا يجازيكم جميعاً خيراً

أستاذ جمال نسأل الله بالمغفرة لأخيك الغالى والف شكر على هذا العمل الرائع والمفيد وهو فعلاً متعوب فيه جعله الله فى ميزان حسناتك

أستاذ طارق كلما حاولت فتح الملف يتوقف الإيكسيل عن العمل ربما تكون المشكلة عندى فقط حيث تم تحميل الملف مرات عديدة ولم يشتكى أحد

الله ينور عمل متعوب فيه أقترح الآتى 1. إضافة اللغة الفرنسية بعد التربية الدينية وهى من 30 درجة والنجاح من 12 وهى ليست مادة رسوب ( حتى الآن ) ويمكن جعلها إختيارية بتشيك بوكس أى تظهر إذا تم وضع علامة تفيد العمل بها 2. زيادة العدد فى الشيت إلى 1500 طالب 3. حماية بيانات الطلاب و أسمائهم و شيت الشهادات بكلمة حماية حيث لا ينبغى أن تكون الاسماء متاحة لمن يرصد الدرجات أى يتم إزالة الأسماء وأرقام الجلوس من شيتات رصد التحريرى والإكتفاء فقط بالرقم السرى والله الموفق

Sub حماية() Cells.Select Selection.Locked = True Selection.FormulaHidden = True End Sub