عبدالله باقشير

الشكر واصل لجميع المشاركين حفظكم الله ورعاكم وعفوا على التاخير خبور خير

السلام عليكم انت تعرف ان المرفق قديم وممكن اختصاره ولكن يحتاج تركيز ووقت وحسب طلبك تم التعديل في الجزئية هنا For C = 1 To SheetCount For D = 1 To StusentsNum 'For E = 1 To CmNO F = D + A G = D + B '.Cells(F, E) = MyRange.Cells(G, E) With Range(.Cells(F, 1), .Cells(F, CmNO)) .Value = Range(MyRange.Cells(G, 1), MyRange.Cells(G, CmNO)).Value .Borders.LineStyle = xlContinuous End With 'Next E Next D A = A + StusentsNum + RowsUp + RowsDown B = B + StusentsNum Next C المرفق اكسل 2003 التقسيم لشيتات3.rar

السلام عليكم جمعة مباركة هذا الكود يوضع في الوحدة النمطية للورقة Private Sub Worksheet_Change(ByVal Target As Range) If Me.[T1] Then Exit Sub If Not Application.Intersect(Target, Range("F3:F12")) Is Nothing Then Application.EnableEvents = False Application.Undo Application.EnableEvents = True MsgBox "خلية لا يمكن تعديلها" End If End Sub ايضا يوجد رابط تحميل في رابط المدونة ادنى التوقيع حماية خلايا معينة من التعديل.rar

السلام عليكم اخي الحبيب /يحي حسين ______حفظه الله

آمين با رب العالمين

السلام عليكم كود بحث في جميع الاوراق الظاهرة مع تحديد و تلوين خلية النتيجة Option Explicit Sub Kh_Find_All() Dim MyTextFind, OldColor Dim MySh As Worksheet Dim C As Range Dim FirstAddress As String MyTextFind = Application.InputBox("اكتب ما تريد البحث عنه ؟", "بحث في جميع الاوراق الظاهرة") If MyTextFind = "" Or MyTextFind = False Then Exit Sub For Each MySh In ActiveWorkbook.Worksheets If MySh.Visible = xlSheetVisible Then With MySh.Cells Set C = .Find(MyTextFind, LookIn:=xlValues) If Not C Is Nothing Then FirstAddress = C.Address Do MySh.Activate C.Select OldColor = C.Interior.ColorIndex C.Interior.ColorIndex = 6 If MsgBox("تم ايجاد قيمة البحث في العنوان" & Chr(10) & Chr(10) & MySh.Name & "!" & C.Address _ & Chr(10) & Chr(10) & "هل تريد الاستمرار في البحث ؟", 524288 + 1048576 + 4, "تاكيد") = 7 Then GoTo 1 C.Interior.ColorIndex = OldColor Set C = .FindNext(C) Loop While Not C Is Nothing And C.Address <> FirstAddress End If End With End If Next MySh MsgBox IIf(Len(FirstAddress), "انتهى البحث", "لا توجد نتائج للبحث "), 524288 + 1048576, "بحث" 1: If Len(FirstAddress) Then C.Interior.ColorIndex = OldColor Set C = Nothing End Sub المرفق ملف اكسل 2003 كود بحث في جميع الاوراق الظاهرة مع تحديد و تلوين خلية النتيجة.rar

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

السلام عليكم ممكن تبحث عن اطارات عبر البحث بالنيت او تكونها انت حسب الاشكال الموجودة في اشكال تلقائية ثم تعمل لها تجميع هذه اشياء فنيه وكلا حسب ذوقه

السلام عليكم وقد اخبرتك التالي الاطار الخاص بالشهادة الاولى استدلينه علية بالاسم وهو "Group 6394" الازار والتعليقات استدلينه عليها بنوعية الكائن نوع الكائن الزر هو msoFormControl او الرقم 8 نوع الكائن التعليقات هو msoComment او الرقم 4 =============================================== وساعطيك كود مختصر انت بعد استخدام زر المسح والخفظ سيبقى معاك فقط الاطارات التي قمت باضافتها وسيكون ارتفاع هذه الاطارات بعد حذف الصفوف العدد صفر اذن استخدم هذا الكود : Sub kh_Delete_Group() Dim shp As Shape Dim U As Integer For Each shp In Sheet3.Shapes If shp.Height = 0 Then shp.Delete: U = U + 1 Next shp MsgBox U End Sub جرب واخبرنا بالنتيجة

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

السلام عليكم كلمة السر هي:123 ويتم تغييرها في الكود في السطر If Not MyPas = "123" Then GoTo 1 الكود المستخدم هو: Option Explicit ' ' Sub kh_MySh_Range_ClearContents() On Error Resume Next Dim MySh, Sh, MyPas Dim MyName As String ' اسماء الاوراق MySh = Array("الرئيسية", "بيانات1", "بيانات2") If IsError(Application.Match(ActiveSheet.Name, MySh, 0)) Then MsgBox "اسم الورقة غير مسجلة في الكود في المتغير " & "MySh", vbMsgBoxRtlReading + vbMsgBoxRight: GoTo 2 If Not TypeName(Selection) = "Range" Then MsgBox "The selection object type is " & TypeName(Selection): GoTo 2 1: MyPas = InputBox("هل تريد مسح الخلايا " & Chr(10) & Chr(10) & Selection.Address) If MyPas = "" Then GoTo 2 If Not MyPas = "123" Then GoTo 1 For Each Sh In MySh Sheets(Sh).Range(Selection.Address).ClearContents MyName = MyName & Chr(10) & Sheets(Sh).Name Next Sh Call MsgBox("تم مسح الخلايا " & Selection.Address & Chr(10) & Chr(10) & "في الاوراق التالية : " & MyName, vbMsgBoxRtlReading + vbMsgBoxRight, "الحمد لله") 2: End Sub شاهد المرفق اكسل2003 مسح الخلايا المحددة في اوراق معينة.rar

السلام عليكم الاخ / قصي تم فصل اسئلتك في موضوع منفصل على الرابط http://www.officena.net/ib/index.php?showtopic=35763

السلام عليكم الكود يقوم بمسح الخلايا المحددة في الكود في الورقة الاولى في جميع ملفات الاكسل الموجودة في فايل الملف ما عدى الملف الموجود فيه الكود ------------------------------------------------- يعني يمكنك اضافة اي ملف وستجرى العملية عليه تلقائيا ------------------------------------------------- في هذه الجزئية الموجودة في الكود يحدد الورقة والخلايا المراد مسحها Sheets(1).Select Range("C4:D12").ClearContents ------------------------------------

السلام عليكم الكود التالي يقوم بمسح الخلايا المحددة للاوراق المحددة في الكود: Sub kh_MySh_Range_ClearContents() Dim MySh, Sh MySh = Array("الرئيسية", "بيانات1", "بيانات2") If Not TypeName(Selection) = "Range" Then GoTo 1 For Each Sh In MySh Sheets(Sh).Range(Selection.Address).ClearContents Next Sh 1: End Sub ويمكن استخدام الكود في اي ورقة من هذه الاوراق المحددة في الكود

السلام عليكم استخدم هذا الكود : Option Explicit Sub kh_MyFill_ClearContents() Dim fs, f, f1, fc Dim my_path Dim zz As Integer On Error Resume Next my_path = ActiveWorkbook.Path & "\" Set fs = CreateObject("Scripting.FileSystemObject") Set f = fs.GetFolder(my_path) Set fc = f.Files Application.ScreenUpdating = False For Each f1 In fc If f1.Name = ActiveWorkbook.Name Then GoTo 1 If InStr(f1.Name, ".xls") Then Workbooks.Open Filename:=my_path & f1.Name Sheets(1).Select Range("C4:D12").ClearContents Workbooks(f1.Name).Close True End If 1: Next Application.ScreenUpdating = True 2: If Not Err.Number = 0 Then Err.Clear Set fs = Nothing Set f = Nothing Set fc = Nothing On Error GoTo 0 End Sub المرفق اكسل2003 test.rar

السلام عليكم استخدم هذا الكود للحذف Sub kh_Delete_AllShape() Dim shp As Shape Dim U As Integer For Each shp In Sheet3.Shapes If shp.Type = 8 Or shp.Type = 4 Or shp.Name = "Group 6394" Then GoTo 1 shp.Delete 1: Next shp End Sub هذا سيقوم بحذف الصور والاطارات ما عدى الاطار الخاص بالشهادة الاولى ويبقي الازرار والتعليقات جرب واخبرني النتيجة

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

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

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

لسلام عليكم الاخ الفاضل/ ولد المجرب ________حفظك الله توقيعك مس شي في قلبي ودمعت عيني لما قرأته اكرمك الله حبيبي محمدي / طمني عليك اخي برسالة اخي الجزيره كلمات ننبع من اصلك الكريم اخي عادل بارك الله فيك نحب تواجدك معنا دائما تقبلوا مني جزيل الشكر والتقدير ودمتم في حفظ الله

السلام عليكم عملت التغيير في اصدار جديد ساضيفة لاحقا في موضوع منفصل في بداية الكود تحدد في اول شهادة التالي: موقع الصورة/ موقع خلية اسم الصورة ' موقع خلية وضع صورة الطالب في اول شهادة Const STPic As String = "N12" ' موقع خلية اسم الصورة للطالب في اول شهادة Const STPicValue As String = "G15" شاهد المرفق شهادات جديد مع اضافة صور للطلبة.rar

السلام عليكم بارك الله فيك اخي كيماس تالق ملحوظ ما شاء الله لا قوة الا بالله تقبل تحياتي وشكري

السلام عليكم الافاضل / جلال - زين - خنانا - ابو آلاء - هشام كوكب - باست - ميدو - باست كيماس - حسن علي ---------------------------حفظكم الله اكرمكم الله وعافاكم من كل مكروه لكم مني جزيل الشكر والتقدير

السلام عليكم تعديلات جديدة على كود ترتيب العشرة الاوائل(بعدة اختيارات) الميزه الاولى يعمل تلقائيا من الاختيارات من القوائم نقل الكود الى ملفك: اضغط بيمين الماوس على تبويب الورقة اختار نقل ونسخ اختار المصنف الذي تريد نقل النسخة اليه وحفز انشاء نسخة سينتقل الكود بمعية الورقة لان موقع الكود في نفس الورقة راس وتذييل فارغ مكون من 8 صفوف اكتب ماتريده بدون تقييد المعطيات الضرورية والتي تناسب عملك مكانها بداية الكود وهو في موديل الورقة نفسها '============================================================ '============================================================ ' نطاق البيانات اما ان يكون اسم لنطاق ' او عنوان النطاق مع اسم الورقة Private Const My_Date As String = "الشيت!$A$11:$EA$1000" 'ارقام الاعمدة توضع بالنسبة لنطاق البيانات المسمى وليس للورقة ' عمود رقم الجلوس Private Const cSeat_Number As Integer = 2 ' عمود الاسم Private Const cStudents As Integer = 3 ' عمود الفصل Private Const cClass As Integer = 13 '============================================================ ' قيمة اصغر مجموع(الدرجة) يتم اظهاره Private Const MinDegree As Double = 50 '============================================================ '============================================================ الميزة الاكثر جمالا هي فرز تلقائي بالكود بدون استخدام الفرز الخاص ببيانات الاكسل سريع جدا في اظهار النتائج جمعه مباركة لكم ولنا ودمتم في حفظ الله ترتيب العشرة الاوائل5.rar

السلام عليكم استخدم المعادلة IF(OR(A1="جبر";A1="هندسة");"رياضيات";IF(OR(A1="تاريخ";A1="جغرافيا");"دراسات";A1)) ودمتم