علي المصري

بعد اذن استاذنا الفاضل الاستاذ سليم اجريت التعديل التالي على الكود الأول Sub My_Print_Area() With Sheets("ورقة1") .Rows.Hidden = False .PageSetup.PrintArea = _ .Range("A" & Cells(1, 5) + 1 & ":B" & Cells(1, 7) + 1).Address .PrintPreview End With End Sub or Sub My_Print_Area() With Sheets("ورقة1") .Rows.Hidden = False .PageSetup.PrintArea = _ .Range("A" & Cells(1, 5) + 1 & ":B" & Cells(1, 7) + 1).Address .PrintOut End With End Sub

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

كود لطباعة صفحات معينة On Error Resume Next ActiveWindow.SelectedSheets.PrintOut From:=Range(E1").Value, To:=Range("G1").Value, _ Copies:=1, Collate:=True, IgnorePrintAreas:=False كود لحذف عدد من الصفوف تحدد باستخدام خليتين i = Sheet1.Cells(1, 5) ' Cell E1 j = Sheet1.Cells(1, 7) ' Cell G1 Rows(i & ":" & j).Select Selection.Delete Shift:=xlUp Range("B2").Select

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

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

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

المفروض الجزء الثاني يكون كالتالي For Each Cell In Selection If Cell.Interior.Color = Excel.XlRgbColor.rgbWhite Then 'rgbYellow Cell.ClearContents End If Next ولكن كيف يمكن تشغيل الكودين مع بعض بحيث اذا كان اللون مخالف للون الابيض لا يتم حذف مكوناتها واذا كانت تحتوي على معادلات لا يتم حذف مكوناتها

شكرا جزيلا على اهتمام حضرتك تم تحويل الخطوات التي ارسلتها الى الكود التالي Range("A2:G13").Select Selection.SpecialCells(xlCellTypeConstants, 23).Select Selection.ClearContents Range("B2").Select ولكن باقي الجزء الاخير وهو عدم حذف محتويات الخلايا الملونة باللون الأصفر مثلا

السلام عليكم ورحمة الله وبركاته هل يمكن عمل كود لحذف البيانات داخل الخلايا في نطاق معين مع عدم حذف المحتويات الخاصة بالخلية في حالة وجود دوال في هذه الخلايا وعدم حذف محتويات الخلايا الملونة بلون معين ( اللون الاصفر مثلا ) شاكرا لكم تعاونكم Book1.xlsx

السلام عليكم ورحمة الله وبركاته لدي درجات للطلاب من 40 درجة اريد تحويلها الى درجة من 10 ( هذه اعرفها ) اريد عند تنفيذ الكود يتم ترحيل هذه الدرجات إلى نطاق خلايا جديد بدلا من التحويل في نفس خلية الدرجة هذا الكود يحول الدرجات ولكن في نفس الخلية For Each cell In [P10:T24] ' If cell = "" Then Exit Sub cell.Value = WorksheetFunction.Round(cell.Value / 4, 0) If cell.Value >= 0 Then Range("E10:I24").Value = Range("P10:T24").Value Next cell

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

السلام عليكم ورحمة الله وبركاته عند تشغيل قاعدة البيانات الخاصة بي تعطي الرسالة الموضحة ( جهاز جديد ونسخة وندوز 10 واوفيس 2016 ) مع العلم انها تعمل بشكل ممتاز على اي جهاز آخر وعليه نفس الاوفيس والويندوز فمال الحل الرسال التي تظهر كالتالي

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

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

ما اقصده موضح بالمرفق جزاكم الله خيرا 111.rar

شكرا على الاهتمام ولكن المطلوب كما يلي عند نسخ بيانات من ملف اخر وعمل لصق لهذه البيانات في ملف الاكسيل سواء عن طريق استخدام Ctrl+V أو أي طريقة أخرى يبدأ تنفيذ الكود ويجعل عملية اللصق ( لصق القيم فقط ) ( أي لا يتم لصق التنسيق والمعادلات وغيرها ) مع الشكر الجزيل

السلام عليكم ورحمة الله وبركاته اريد كود يقوم بعمل لصق البيانات المنسوخة على شكل قيم فقط code for paste copy data as value only

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

الدالة IFERROR على حد علمي

استخدم الكود في الصورة التالية Sub Circles1() On Error Resume Next Call DeletingShp Dim ws As Worksheet, C As Range, E As Range, F As Range Dim MyRng As Range, MyRng2 As Range, MyRng3 As Range, V As Shape Dim G As Integer, R As Integer, D As Integer Application.ScreenUpdating = False Set ws = Sheets("شهادات الرابع") Dim i As Integer Dim j As Integer For i = 2 To 12 For j = 1 To 70 Step 13 Set MyRng = ws.Cells("25" + j, i) Set MyRng2 = ws.Cells("24" + j, i) Set MyRng3 = ws.Cells("26" + j, i) For Each C In MyRng: For Each E In MyRng2: For Each F In MyRng3 If C.Value < E.Value Then Set V = ActiveSheet.Shapes.AddShape(msoShapeOval, C.Left + 1, C.Top + 1, C.Width, C.Height - 1) V.Fill.Visible = msoFalse V.Line.ForeColor.SchemeColor = 10 V.Line.Weight = 1.9 V.Shadow.Visible = msoFalse ElseIf F.Value = "دون المستوى" Then Set V = ActiveSheet.Shapes.AddShape(msoShapeRectangle, C.Left + 2, C.Top + 2, C.Width - 5, C.Height - 5) V.Fill.Visible = msoFalse V.Line.ForeColor.SchemeColor = 10 V.Line.Weight = 1.9 V.Shadow.Visible = msoFalse End If Next: Next Next Next Next Application.ScreenUpdating = True End Sub يمكن استخدام السطر التالي لجعل اللون أزرق بدل الأحمر للمربع V.Line.ForeColor.SchemeColor = 4 الكود في المرفق دوائر حمراء-Last.rar

اكيد احضرتك حذفت الكود التالي Sub DeletingShp() Dim shp As Shape For Each shp In ActiveSheet.Shapes If shp.Type = 1 Then shp.Delete Next shp End Sub

استخدم الكود التالي بعد التعديل Sub Circles1() On Error Resume Next Call DeletingShp Dim ws As Worksheet, C As Range, E As Range, F As Range Dim MyRng As Range, MyRng2 As Range, MyRng3 As Range, V As Shape Dim G As Integer, R As Integer, D As Integer Application.ScreenUpdating = False Set ws = Sheets("شهادات الرابع") Dim i As Integer Dim j As Integer For i = 2 To 12 For j = 1 To 70 Step 13 Set MyRng = ws.Cells("25" + j, i) Set MyRng2 = ws.Cells("24" + j, i) Set MyRng3 = ws.Cells("26" + j, i) For Each C In MyRng: For Each E In MyRng2: For Each F In MyRng3 If C.Value < E.Value Or F.Value = "دون المستوى" Then Set V = ActiveSheet.Shapes.AddShape(msoShapeOval, C.Left + 1, C.Top + 1, C.Width, C.Height - 1) V.Fill.Visible = msoFalse V.Line.ForeColor.SchemeColor = 10 V.Line.Weight = 1.9 V.Shadow.Visible = msoFalse End If Next: Next Next Next Next Application.ScreenUpdating = True End Sub

لازم تربط الكود مع كل زر تستخدمه لاظهار الشهادات القائمة المنسدلة وزر التبديل حيث انه عند استخدام القائمة المنسدلة لابد من ربطها مع الكود حتى يعمل الكود

الشرح في الصورة بالتوفيق ان شاء الله تتكرر بعد 13 صف ممكن تحتلف على حسب عدد الصفوف من أول شهادة إلى الثانية

تم التعديل ‏‏2017شيت مدرستى - الصف الرابع 44-44-.rar