ابراهيم الحداد

السلام عليكم ورحمة الله الكود الاول لاستحداث اوراق عمل جديدة حسب اسماء الفصول Sub AddNewSheets() Dim ws As Worksheet Dim ShList As Range Dim C As Range With Worksheets("رصد الدرجات") Set ShList = .Range("E6:E" & .Range("E" & .Rows.Count).End(xlUp).Row) End With On Error Resume Next For Each C In ShList If Len(Trim(C.Value)) > 0 Then If Len(Worksheets(C.Value).Name) = 0 Then Worksheets.Add(after:=Worksheets(Worksheets.Count)).Name = C.Value End If End If Next Call TrnsCls End Sub اما الكود الثانى هو مخصص لجلب بيانات الفصول Sub TrnsCls() Dim ws As Worksheet, Sh As Worksheet Dim R As Long Dim p As Long Application.ScreenUpdating = False p = 5 Set ws = Sheets("رصد الدرجات") For Each Sh In Worksheets For R = 6 To 204 If Trim(ws.Cells(R, 5).Value) = Trim(Sh.Name) Then p = p + 1 Sh.Range(Sh.Cells(p, 1), Sh.Cells(p, 104)).Value = ws.Range(ws.Cells(R, 1), ws.Cells(R, 104)).Value Sh.Cells(p, 1)=p-5 End If Next p = 5 Next Application.ScreenUpdating = True End Sub يخصص زر للكود الاول فقط لان الثانى يتم استدعاؤه من خلال الكود الاول التنسيق عليك ياصديقى هذا و بالله التوفيق

السلام عليكم ورحمة الله انسخ هذا الكود و الصقه فى موديول وخصص له زر Sub NumeicData() Application.ScreenUpdating = False For i = 4 To Range("N" & Rows.Count).End(xlUp).Row If Cells(i, "B") = "الإســـــــــم /" Then p = p + 1 Cells(i, "Q") = 1000 + p Else Cells(i, "Q") = "" End If Next Application.ScreenUpdating = True End Sub

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

السلام عليكم ورحمة الله اكتب الكود التالى فى موديول Sub ColoredRows() For i = 10 To 34 For Each c In Range("E10:E34") If Cells(i, "H") <> "" Then If c.Value = Cells(i, "H") Then Range(Cells(c.Row, 2), Cells(c.Row, 5)).Interior.ColorIndex = 10 End If End If Next Next End Sub وفى حدث الصفحة اكتب الكود التالى Private Sub Worksheet_Change(ByVal Target As Range) If Target.Column <> 8 And Target.Row < 10 And Target.Row > 34 Then Exit Sub Call ColoredRows End Sub

السلام عليكم ورحمة الله اكتب هذه المعادلة فى الخلية "A3" ثم اسحب نزولا =VLOOKUP(B3;$D$3:$E$13;0)

السلام عليكم ورحمة الله عذرا اخى الكريم على التأخير استبدل هذه العبارة Copy:=1 بهذه العبارة Copies:=1

السلام عليكم ورحمة الله اخوانى واحبائى اعضاء منتدانا العظيم احبتى اعضاء كنترول التعليم التجارى بعد ان تم تقديم شيت كنترول الصف الثانى الآن اقدم لكم هذا الملف المتواضع لشيت كنترول الصف الاول ارجو أن ينال اعجابكم هذا والله ولى التوفيق اولى - ت.rar

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

السلام عليكم ورحمة الله اخى الحبيب ناصر لا اخفيك سرا ان العمل فى التعليم العام يختلف تماما عن التعليم الفنى سوف تلاحظ اختلافا كبير بين الشيت الخاص بمدارس التعليم الفنى والتعليم العام على كافة الاصعدة على سبيل المثال لا الحصر , الرصد يتم فى شيت الشعبة مباشرة و لا يتم التسجيل فى صفحة خاصة بالرصد ثم يتم الترحيل كما هو الحال فى التعليم العام سوف تلاحظ عدم ادراج البيانات الخاصة بتاريخ ميلاد الطالب او عمر الطالب فى سن معين ............... وهكذا دواليك و عذرا على تأخير الرد ودمتم فى رعاية الله

السلام عليكم ورحمة الله ضع فى الخلية "P1" ترتيب اول شهادة تريد طبعها و الخلية "P2" آخر شهادة تريد طبعها ثم انسخ هذا الكود وضعه فى موديول وخصص له زر و سيقوم الكود بتعديل القيم تلقائيا Sub PrintArea() Dim i As Integer, j As Integer, x As Integer, y As Integer x = Sheet3.Range("P1").Value y = Sheet3.Range("P2").Value i = (x * 12) + 1 j = (y + 1) * 12 Sheet3.PageSetup.PrintArea = Sheet3.Range("B" & i & ":L" & j).Address Sheet3.PrintPreview Sheet3.PrintOut from:=1, to:=2, Copy:=1 x = x + 2 y = y + 2 Sheet3.Range("P1").Value = x Sheet3.Range("P2").Value = y End Sub

السلام عليكم ورحمة الله هذه محاولة متواضعة ارجو تجريب هذا الكود انسخ هذا الكود والصقه فى موديول و اربطه بزر Sub ChosFacu() Dim C As Range, Fac As String Dim x As Integer, y As Integer, z As Integer For Each C In Range("C2:C9") x = WorksheetFunction.CountIf(Range(C, Range("C2")), C) y = WorksheetFunction.VLookup(C, Range("M2:N6"), 2, 0) z = x - y If z <= 0 Then Cells(C.Row, 8) = C.Value Else Cells(C.Row, 8) = C.Offset(0, z + 1).Value End If Next End Sub

السلام عليكم ورحمة الله اخى الكريم / ناصر اليك شرح الكود كما طلبت Sub RangLY() ' كود شهادات آخر العام لجميع الشعب Dim ws As Worksheet, sh As Worksheet 'الشيتات التى سيتم العمل عليها Dim Arr As Variant 'مصفوفة لاعمدة الدرجات Dim x, y, z, r, s As Long ' متغيرات للتحكم فى عدد الشهادات التى ينطبق عليها الشرط Set ws = Sheets("شهادة آخر العام") 'تعريف الشيت الاول Set sh = Sheets(ws.Range("X2").Value) حيث القائمة المنسدلة التى تحوى 4 شيتات ("X2") الشيت الثانى يتم تحديد كما فى الخلية المذكورة Application.ScreenUpdating = False ' استدعاء اسماء المواد حيث تختلف من شعبة الى اخرى Call SubjectsNames3 ' مسح الدوائر حال وجودها للحاصلين على ملاحق Call RemovShp مصفوفة اعمدة الدرجات Arr = Array(10, 14, 18, 22, 26, 30, 34, 38, 42, 46, 50, 59, 60, 64, 68) ' بداية العد من الشهادات المطلوب عرضها y = 9 + (ws.Range("T1").Value - 1) * 3 + 1 ' ترتيب آخر شهادة مطلوب عرضها z = 9 + ws.Range("T1").Value * 3 ' اول سطر يحتوى بيانات s = 11 النطاق الذى سيتم العمل عليه فى الشيتات المقصودة For r = y To z ' نطاق الاعمدة المحددة بالمصفوفة For x = LBound(Arr) To UBound(Arr) ' استدعاء درجات الشهادة ws.Cells(s, x + 6) = sh.Cells(r, Arr(x)) ' الاوامر التالية لاستدعاء اسم الطالب ورقم جلوسه وفصله وشعبته و المواد الراسب فيها اذا كان راسبا ws.Cells(s - 5, 19) = sh.Cells(r, 4) ws.Cells(s - 4, 6) = sh.Cells(r, 3) ws.Cells(s - 4, 19) = sh.Cells(r, 2) ws.Cells(s - 5, 14) = ws.Cells(2, 24) ws.Cells(s + 1, 6) = sh.Cells(r, 69) & " : " & sh.Cells(r, 70) Next ' تكرار تنفيذ الامر بعد 11 صف حتى آخر شهادة بالورقة s = s + 11 Next ' استدعاء كود رسم الدوائر لطالب الملاحق Call Crl_Shp Application.ScreenUpdating = True End Sub

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

السلام عليكم ورحمة الله اليك الكود بعد التعديل Sub الاصغر() Dim ws As Worksheet Dim LR As Long Set ws = Sheets("ورقة1") LR = ws.Range("B" & Rows.Count).End(xlUp).Row ws.Range("B2:J" & LR).Sort Key1:=ws.Range("H2"), Order1:=xlDescending, Key2:=ws.Range("B2"), Order2:=xlAscending, Header:=xlNo MsgBox LR End Sub

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

السلام عليكم ورحمة الله استبدل هذا السطر If IsNumeric(Cells(R, c.Column)) And Not IsEmpty(Cells(R, c.Column)) And (c.Value < Cells(R, c.Column) Or c.Value = "غ" Or c.Value = "غـ") And c.Value <> "" Then بهذا السطر If IsNumeric(Cells(R, c.Column)) And Not IsEmpty(Cells(R, c.Column)) And (c.Value < Cells(R, c.Column) / 2 Or c.Value = "غ" Or c.Value = "غـ") And c.Value <> "" Then

السلام عليكم ورحمة الله اجعل الكود هكذا Sub الاصغر() Range("B2:J1000").Sort Key1:=Range("B2:B1000"), Order1:=xlAscending, Key2:=Range("H2:H1000"), Order2:=xlDescending, Header:=xlNo End Sub

السلام عليكم ورحمة الله اذهب الى الكود المسى Circles1 و عدل هذا G = 14 الى ذلك G = 12 هذا و بالله التوفيق

لسلام عليكم ورحمة الله اذا اردت ان تعرف الشهر كرقم اكتب المعادلة التالية =MONTH(اسم الخلية التى بها التاريخ) اما اذا اردت ان تعرف اسم الشهر كنص اكتب المعادلة التالية =TEXT(اسم الخلية التى بها التاريخ;"mmm")

السلام عليكم ورحمة الله غير تنسيق الخلية الى NUMBER

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

السلام عليكم ورحمة الله اكتب المعادلة التالية فى الخلية "C4" =IF(COUNTIF($B$4:$B$13;B4)<=$D$1;B4+1;B4) ثم اسحب نزولا

السلام عليكم ورحمة الله استبدل هذا السطر d = WorksheetFunction.Text(Date , "dd_mm_yyyy") بهذا السطر d = WorksheetFunction.Text((Date - 1), "dd_mm_yyyy")

السلام عليكم ورحمة الله استخدم هذا الكود Sub HidRows() Dim C As Range For Each C In Range("A2:A" & Range("A" & Rows.Count).End(xlUp).Row) If C.Value = "نعم" Then C.EntireRow.Hidden = True End If Next End Sub

السلام عليكم ورحمة الله عفوا اخى الكريم / ناصر فالرد السابق سيجمع بين اسماء الناجحين من البنين والبنات وبمراجعة الخطأ لابد من اعادة نسخ كلمة ناجح من العمود 101 فى الورقة الاولى ولصقها فى الخلية "G1" بالورقة الثانية و كذلك فى كل المعايير التى لا تعمل معك والله ولى التوفيق