كل الانشطه

السلام عليكم ورحمة الله وبركاته لدى ملف اكسيل يحتوى على كود لانشاء ملف باسم خاص ويحفظ فى مسار معين لحد هنا لا توجد مشكله اريد ان انقل مديول رقم1 وكود يعمل فى حدث فتح الملف هل هذا ممكن كود انشاء الملف Sub new_workbook() Dim ws As Worksheet Dim Path As String Path = CreateObject("WScript.Shell").SpecialFolders("startup") & "\" With Workbooks.Add .SaveAs Filename:=(Path & "rd" & ".xlsm"), FileFormat:=52 .Close End With End Sub سعد.xlsm

وعليكم السلام ورحمة الله وبركاته .. الموضوع ليس صعباً كما تتصور !! هو فقط يحتاج منك ممارسة ومتابعة ومطالعة مواضيع تعليمية وفيديوهات تشرح المبادئ نفسها من الصفر . جميعنا هنا تعلمنا من أخطائنا ومن تجاربنا ومن معلمينا وأساتذتنا الأفاضل بلا شك ، وهنا يأتي دورك أولاً بتعلم الأساسيات التي عندما تتقنها ستجد أنك قطعت شوطاً كبيراً في فهم آلية كتابة الأكواد .

وعليكم السلام ورحمة الله وبركاته .. أخي الفاضل ، الملف المرفق فتح عندي دون ظهور أي مشاكل في اللغة العربية والمسميات كما أرفقت صورتك سابقاً . لذا من الواضح ان مشكلتك في إعدادات الترميز في اللغة العربية .. مشكلتك حلها تقريباً كتطبيق عملي على إصدار ويندوز 10 كما في الصورة التالية :- قد تختلف قليلاً في ويندوز 11 ، ولكن المبدأ واحد ؛ وهو ذهابك الى لوحة التحكم - Control Panel ثم كما في الصورة التالية :- أو ثم اكمل باقي الخطوات كالتالي :- وبعدها سيطلب منك إعادة تشغيل الكمبيوتر لتطبيق التعديلات .

وعليكم السلام ورحمة الله وبركاته وبخصوص شرح جملة الاستعلام الموضوع بيعتمد على مقارنة بين سجلات الجدول نفسه باستخدام دالة EXISTS واستعلام فرعي الاستعلام يقوم بتحديث جدول tblEshtrakatTsdeed وبالتحديد الحقل jad بحيث يتم تعيين قيمته إلى True للسجلات التي تستوفي شرط معينه الشرط يعتمد على مقارنة بين سجلات الجدول نفسه من خلال استعلام فرعي Subquery خلينى أفصل مكونات الاستعلام علشان نبسط الدنيا شوية جزء التحديث : UPDATE UPDATE tblEshtrakatTsdeed AS t1 SET t1.jad = True تم استخدام AS t1 لإعطاء الجدول اسم مستعار :t1 لتسهيل الإشارة إليه داخل الاستعلام خاصة عند مقارنة سجلات الجدول نفسه و يتم تعيين قيمة العمود jad إلى True للسجلات التي تحقق الشرط شرط التحديث WHERE EXISTS ( SELECT 1 FROM tblEshtrakatTsdeed AS t2 WHERE t2.usrID = t1.usrID AND t2.lstDate > t1.lstDate ) هذا الشرط يحدد السجلات في الجدول tblEshtrakatTsdeed (المحدد باسم t1) سيتم تحديثها بناء على وجود سجلات أخرى في نفس الجدول المحدد باسم :t2 والتى تحقق شروط معينة دالة EXISTS: تتحقق مما إذا كان هناك سجل واحد على الأقل في الاستعلام الفرعي يحقق الشرط ليتم تحديث السجل في t1 الاستعلام الفرعي: SELECT 1 FROM tblEshtrakatTsdeed AS t2 WHERE t2.usrID = t1.usrID AND t2.lstDate > t1.lstDate SELECT 1: في استعلامات بها دالة EXISTS بدلا من استرجاع بيانات فعلية يتم إرجاع قيمة ثابتة (1) لأننا نهتم فقط بوجود السجل وليس بمحتواه FROM tblEshtrakatTsdeed AS t2: نفس الجدول tblEshtrakatTsdeed ولكن باسم مستعار مختلف:t2 وذلك حتى نستطيع تمييزه عن t1 الشرط: t2.usrID = t1.usrID: يتطابق معرف المستخدم (usrID) بين السجل في t1 والسجل في t2 هذا يعني أننا نبحث عن سجلات لنفس المستخدم t2.lstDate > t1.lstDate: يتحقق مما إذا كان تاريخ السجل في t2 (الموجود في العمود lstDate) أحدث (أكبر) من تاريخ السجل في t1

السلام عليكم انا حاولت ولكن توجد مشكله لا اعرف ما هي ممكن المساعده و حلها وطريقة الحل ماكرو.xlsm

تقريبا المشكلة فالاوفيس جربته على جهاز تاني اشتغل

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

الاخ الفاضل :مصطفى حماد سيد حماد لكي تنفذ طلبك عليك بالتالي اولا الطلبة الناجحين من الصف الثالث تنفذ عليهم استعلام تحديث بيانات و تنقلهم للصف الرابع - أي تجعل الرقم الدال على الصف=4- على سبيل المثال - ( يعني تم تخرجهم لان المرحلة 3 صفوف فقط) ثانيا الطلبة الناجحين من الصف الثاني تنفذ عليهم استعلام تحديث و تجعل الرقم الدال على الصف = 3 ثالثا و أخيرا الطلبة الناجحين من الصف الاول تنفذ عليهم استعلام تحديث لرقم الصف و تجعله = 2 رابعا لا بد من تنفيذ الاستعلامات بالترتيب المشار اليه سابق. خامسا الطلبة الراسبين يبقي في نفس الدرجة و لكن ممكن تغير الحقل الدالة على حالته و تجعله = باقي للاعادة اما الجديد يكون حالته مستجد

السلام عليكم : ما شاء الله كم نتعلم من هذا الحوار الراقي بين استاذة المنتدي و لكي تعم الفائدة هل من الممكن أن يشرح الاستاذ ابو جودي بقليل من التفصيل الكود المستخدم في عمل الاستعلام الاول UPDATE tblEshtrakatTsdeed AS t1 SET t1.jad = True WHERE EXISTS ( SELECT 1 FROM tblEshtrakatTsdeed AS t2 WHERE t2.usrID = t1.usrID AND t2.lstDate > t1.lstDate ); و جزاكم الله خيرا

Private Sub UserForm_Initialize() Me.TextBox3.Value = Format(Date, "dd/mm/yyyy") Me.TextBox3.Locked = True Me.TextBox2.Value = "" End Sub Castrole v3.xlsm

هناك واحد من سببين لهذه المشكلة .. إما أنك قمت بنسخ الأكواد ومؤشر الكتابة ( لغة الكيبورد = انجليزية ) ، وهو هنا مستبعد .. وإما الحل الثاني ويكمن الحل بمراجعة الموضوع التالي :- حيث أنصحك باستخدام آخر إصدار للأداة لضبط لغة الترميز Unicode حسب بلدك .. في هذه المشاركة = الإصدار الأخير ..

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

تقريبا المشكلة تقريبا هنا اللغة مش مظبوطه

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

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

تم تعديل المرفق ليعمل على جميع الانوية ضبط النموذج على الشاشة.accdb

السلام عليكم لايوجد اي فرق بيننا ابدا نحن فريق واحد ان شاء الله

آها .. التعديل لك عذرا كان المثال محفوظ عندي باسم الأخ صالح 😇 لم اكن متواجدا في النقاش عند طرح الموضوع .. او اني نسيت 😔 المهم في الموضوع هي الفكرة

السلام عليكم انا جربت الكود على الشاشات التالية : 800*600 1024*768 1280*720 1280*768 1360*768 1920* 1080 يعمل بصورة صحيجة عندي بعد ان قمت بتعديل حجم الخط بالنسبة للقوائم المنسدله والحقول لتتلائم مع التكبير والتصغير وهذا كود الاخ @صالح حمادي Option Compare Database Function salah(frm As Form) Dim x, y, x1, y1 As Integer Dim moyH, moyW As Double Dim obj As Control Dim str As String x = frm.InsideHeight 'ارتفاع النموذج قبل التكبير y = frm.InsideWidth ' عرض النموذج قبل التكبير DoCmd.Maximize x1 = frm.InsideHeight 'ارتفاع النموذج بعد التكبير y1 = frm.InsideWidth ' عرض النموذج بعد التكبير moyH = x1 / x 'معامل الإرتفاع moyW = y1 / y ' معامل العرض For Each obj In frm.Controls With obj .Left = .Left * moyW .Top = .Top * moyH .Width = .Width * moyW .Height = .Height * moyH .FontSize = .FontSize * moyW End With Next End Function وهذا الكود بعدل التعدبل علية من حيث جحم الخطوط Option Compare Database Option Explicit Function ResizeForm(frm As Form) On Error GoTo ErrorHandler Dim X As Long, Y As Long, x1 As Long, Y1 As Long Dim moyH As Double, moyW As Double Dim obj As Control Dim maxFontSize As Integer Dim newFontSize As Double maxFontSize = 20 ' الحد الأقصى لحجم الخط ' أبعاد النموذج قبل التكبير X = frm.InsideWidth ' عرض النموذج قبل التكبير Y = frm.InsideHeight ' ارتفاع النموذج قبل التكبير ' تكبير النموذج DoCmd.Maximize ' أبعاد النموذج بعد التكبير x1 = frm.InsideWidth ' عرض النموذج بعد التكبير Y1 = frm.InsideHeight ' ارتفاع النموذج بعد التكبير ' حساب معامل الارتفاع والعرض moyH = Y1 / Y moyW = x1 / X ' تعديل خصائص كل عنصر في النموذج For Each obj In frm.Controls With obj ' ضبط الموضع والحجم .Left = .Left * moyW .Top = .Top * moyH .Width = .Width * moyW .Height = .Height * moyH ' تعديل حجم الخط إذا كان العنصر يدعم ذلك If .ControlType = acTextBox Or .ControlType = acLabel Or .ControlType = acCommandButton Or .ControlType = acComboBox Then If Not IsNull(.FontSize) Then newFontSize = .FontSize * moyH If newFontSize > maxFontSize Then .FontSize = maxFontSize ElseIf newFontSize < 6 Then .FontSize = 6 ' الحد الأدنى لحجم الخط Else .FontSize = newFontSize End If End If End If End With Next obj Exit Function ErrorHandler: MsgBox "حدث خطأ: " & Err.Description, vbCritical End Function وهذا الملف النهائي بعد التعديل تحياتي ملائمة النموذج حسب حجم الشاشة.accdb

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

و عليكم السلام ورحمة الله و بركاته أخي العزيز محمد لقد طلبت عدة أشياء في بوست سابق لها علاقة بهذا الموضوع و قدمنا بعض الحلول و تم تقديم برنامج بسيط يفي بالغرض و لكنك لم تقم بالرد أو تبدي أي ملاحظة على الملف وهذا يسبب احباط لمن أعد و جهز هذا الملف الذي نبتغي به أولا الأجر من الله سبحانه و تعالى ثم مساعدة الأخوة في هذا المنتدى و الذي تخرج منه أساتذة الأكسيل في الوطن العربي. و لذلك فضلا منك قم بالرد على اي مشاركة لسؤالك خاصة إذا كان الحل مرهق و يستغرق وقتا. جزاك الله الخير الكثير الموضوع موجود في الرابط التالي https://www.officena.net/ib/topic/139393-قاعدة-لاجازات-العاملين/#comment-774531

وجدت هذا الموضوع ، إن كان يفيدك أيضاً .. وهو تابع لموضوع سابق قمت بالإشارة إليه ..

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

السلام عليكم اولا انا عارف ان الموضوع متعب انا بحاول اتعلم من حضراتكم ارجو المساعدة في الشيت الاتي الملف مكون من اكثر من شيت ويريت كتابة الاكواد المستحدمه ولو ممكن شرحها للاستفادة 2010.xlsx

الحل ممكن من خلال الأكواد: و لكن لا تنسى تفعيل اذهب إلى File > Options > Trust Center > Trust Center Settings ثم اذهب إلى Macro Settings فعل الخيار: "Trust access to the VBA project object model" أولا تضع الكود التالي في الملف الذي تريد التصدير منه ' officena.net Sub ExportAllComponentsDynamically() ' --- هذا الكود يقوم بتصدير جميع المكونات ديناميكيًا --- Dim vbComp As Object ' VBComponent Dim exportPath As String Dim componentName As String Dim fileExtension As String ' 1. حدد مسار التصدير exportPath = "C:\ExcelComponents\" ' 2. تأكد من وجود المجلد If Dir(exportPath, vbDirectory) = "" Then MkDir exportPath End If ' 3. ابدأ الحلقة للمرور على كل مكون في المشروع For Each vbComp In ThisWorkbook.VBProject.VBComponents ' تجاهل المكونات الخاصة بالأوراق (Worksheets) و ThisWorkbook If vbComp.Type = 100 Then ' 100 = vbext_ct_Document GoTo NextComponent End If ' 4. حدد امتداد الملف بناءً على نوع المكون Select Case vbComp.Type Case 1 ' vbext_ct_StdModule fileExtension = ".bas" Case 2 ' vbext_ct_ClassModule fileExtension = ".cls" Case 3 ' vbext_ct_MSForm fileExtension = ".frm" Case Else ' تجاهل الأنواع الأخرى GoTo NextComponent End Select ' 5. احصل على اسم المكون componentName = vbComp.Name ' 6. قم بتصدير المكون بالاسم والامتداد الصحيحين Debug.Print "Exporting: " & componentName & fileExtension vbComp.Export exportPath & componentName & fileExtension NextComponent: Next vbComp MsgBox "تم تصدير جميع المكونات بنجاح إلى: " & exportPath End Sub ثانيا تضع الكود التالي في الملف الذي تريد استيراد العناصر إليه ' officena.net Sub ImportAllComponentsDynamically() ' --- هذا الكود يقوم باستيراد جميع المكونات من مجلد محدد --- Dim importPath As String Dim fileName As String ' 1. حدد مسار الاستيراد importPath = "C:\ExcelComponents\" If Dir(importPath, vbDirectory) = "" Then MsgBox "المجلد المحدد غير موجود!", vbCritical Exit Sub End If ' 2. ابدأ بالبحث عن الملفات fileName = Dir(importPath & "*.*") On Error Resume Next ' لتجاهل الأخطاء (مثل محاولة استيراد مكون موجود) ' 3. ابدأ الحلقة للمرور على كل ملف في المجلد Do While fileName <> "" ' 4. تحقق من امتداد الملف قبل الاستيراد If LCase(Right(fileName, 4)) = ".frm" Or _ LCase(Right(fileName, 4)) = ".bas" Or _ LCase(Right(fileName, 4)) = ".cls" Then Debug.Print "Importing: " & fileName Application.VBE.ActiveVBProject.VBComponents.Import importPath & fileName End If ' انتقل إلى الملف التالي fileName = Dir Loop On Error GoTo 0 MsgBox "اكتملت عملية الاستيراد!" End Sub جرب و أبلغنا بالنتيجة اويمكنك استخدام الكود التالي لاستيراد أي عناصر تريدها مباشرة 'Officena.net Sub ImportComponents() ' --- الإصدار الثالث المصحح: استخدام Or بدلاً من In --- Dim sourceWB As Workbook Dim targetWB As Workbook Dim sourceFilePath As Variant Dim tempFolderPath As String Dim vbComp As Object ' VBComponent Dim componentName As String Dim fileExtension As String Dim fileName As String ' --- 1. الإعدادات الأولية --- sourceFilePath = Application.GetOpenFilename( _ FileFilter:="Excel Macro-Enabled Files (*.xlsm), *.xlsm,All Excel Files (*.xls*), *.xls*", _ Title:="الرجاء اختيار ملف Excel المصدر الذي تريد استيراد المكونات منه", _ MultiSelect:=False) If sourceFilePath = False Then MsgBox "تم إلغاء العملية.", vbInformation Exit Sub End If tempFolderPath = Environ("TEMP") & "\VBA_Import_" & Format(Now, "yyyymmdd_hhmmss") & "\" If Dir(tempFolderPath, vbDirectory) = "" Then MkDir tempFolderPath Set targetWB = ThisWorkbook Application.ScreenUpdating = False ' --- 2. فتح المصدر وتصدير المكونات --- On Error GoTo ErrorHandler Set sourceWB = Workbooks.Open(sourceFilePath, ReadOnly:=True, UpdateLinks:=0) sourceWB.Windows(1).Visible = False For Each vbComp In sourceWB.VBProject.VBComponents If vbComp.Type = 100 Then GoTo NextComponent Select Case vbComp.Type Case 1: fileExtension = ".bas" Case 2: fileExtension = ".cls" Case 3: fileExtension = ".frm" Case Else: GoTo NextComponent End Select componentName = vbComp.Name vbComp.Export tempFolderPath & componentName & fileExtension NextComponent: Next vbComp sourceWB.Close SaveChanges:=False Set sourceWB = Nothing ' --- 3. استيراد المكونات إلى الملف الهدف --- fileName = Dir(tempFolderPath & "*.*") Do While fileName <> "" ' === السطر الذي تم تصحيحه === If LCase(Right(fileName, 4)) = ".frm" Or _ LCase(Right(fileName, 4)) = ".bas" Or _ LCase(Right(fileName, 4)) = ".cls" Then On Error Resume Next targetWB.VBProject.VBComponents.Remove targetWB.VBProject.VBComponents(Left(fileName, InStr(fileName, ".") - 1)) On Error GoTo ErrorHandler targetWB.VBProject.VBComponents.Import tempFolderPath & fileName Debug.Print "تم استيراد: " & fileName End If ' ============================ fileName = Dir Loop ' --- 4. التنظيف --- On Error Resume Next Kill tempFolderPath & "*.*" RmDir tempFolderPath On Error GoTo 0 Application.ScreenUpdating = True MsgBox "اكتملت عملية استيراد المكونات بنجاح من الملف: " & vbCrLf & Mid(sourceFilePath, InStrRev(sourceFilePath, "\") + 1), vbInformation Exit Sub ErrorHandler: MsgBox "حدث خطأ:" & vbCrLf & Err.Description, vbCritical, "خطأ" If Not sourceWB Is Nothing Then sourceWB.Close SaveChanges:=False If Dir(tempFolderPath, vbDirectory) <> "" Then On Error Resume Next Kill tempFolderPath & "*.*" RmDir tempFolderPath On Error GoTo 0 End If Application.ScreenUpdating = True End Sub Test.xlsm