نجوم المشاركات

السلام عليكم ورحمة الله تعالى وبركاته • هدية اليوم هى منتقى التواريخ تم الانتهاء من البرمجة والتطوير بالتعاون مع الاستاذ @Moosak ابداع وروعة وجمال تنسيق التصميم قام به اخى الحبيب و استاذى الجليل الاستاذ @Moosak كل الشكر والتقدير والامتنان على تعبه وحرصه على ان يخرج التطبيق بهذه الافكار الى النور فى ابهى صورة بهذا الشكل مميزات التطبيق وجود جدولين الجدول الاول : tblHolidaySettings هذا الجدول وظيفته هى التأشير على ايام العطلات الاسبوعية تبعا للمؤسسة وبذلك يتم تلوين ايام العطلات لتكون مميزة باللون الاحمر وهذا مثال لاختيار يوميى الجمعة والسبت الجدول الثانى : هذا الجدول وظيفتة اضافة تواريخ العطلات الرسمية للدولة و وصف العطلة عند الانتهاء من تسجيل كل العطلات الرسمية للدولة فى الجدول وبعد فتح منتقى التواريخ تبعا لكل شهر تظهر قائمة بالاعياد والمناسبات الرسمية ويتم تغيير لون خلفية اليوم ليكون معروفا من خلال النظر انه عطلة رسمية وبمجرد التحرك من الاسهم فى لوحة المفاتيح للمرور على الايام او اختيار اليوم بضغطة زر واحدة من الفأرة يتم ظهور وصف العطلة الرسمية فى اسفل مربعات الايام كما بالشكل التالى لاختار اليوم اما بالنقر مرتين على رقم اليوم او تحريك علامة الدائرة الزرقاء لتحديد اليوم من خلال ازرار الاسهم من لوحة المقاتيح ثم الضغط على زر اختيار والموجود بالاسفل يسار النموذج زر الامر المسمى اليوم الحالى ينقل فورا الدائرة الزرقاء الى رقم اليوم الذى يوافق تاريخ اليوم يمكن تغيير اتجاه ترتيب الارقام لتبدأ من اليمين الى اليسار او العكس من خلال الزر الموجود بجوار زر اليوم الحالى : ⇋ طريقة استدعاء الدالة لتعمل مع اى مربع نص يستخدم لادخال و كتابة التواريخ تكون كالاتى عمل زر امر بجوار مربع النص وفى منشئ التعبير لحدث النقر لهذا الزر يتم استدعاء الدالة بالشكل التالى على ان يتم تغير الوصف و اسم مربع النص تبعا لاغراض التصميم =CalendarFor([اسم مربع النص فى النموذج],"اكتب الوصف الدال على مربع نص التاريخ :") ملاحظة الوصف الذى سوف يتم كتابته اثناء استدعاء الدالة سوف يطهر فى اعلى يمين النموذج تحت زر الامر الغاء وان كان مربع النص الخاص بالتاريخ يحتوى بالفع على تاريخ سوف تجد هذا التاريخ ايضا تحت هذا الوصف وشرح الوظائف المختلفة للازرار من لوحة المفاتيح التى يمكن التعامل معها بسهولة موجود فى الزر اعلى اليسار " ؟ " اتمنى لكم تجربة شيقة واتمنى ان اكون قدمت اليكم شيئا عمليا ويعود عليكم بالنفع تم اضافة اصدار جديد لتنقيح وتفادى بعض الاخطاء بتاريخ 22/09/2024 - ضبط اسهم زيادة او نقصان الشهور والسنوات تبعا لترتيب واجهة ترتيب التواريخ ( يمين / يسار ) - ضبط الفتح التلقائى لقائمة السنوات او الشهور لاغلاقها اذا كانت مفتوحة بدلا من اعادة فتح القائمة مرة اخرى عند تكرارا الضغط رقم الاصدار الجديد 4 Handler - calendar (V3).zip Handler - calendar (V4).accdb

العفو اخي يسعدنا اننا استطعنا مساعدتك

تفضل اخي Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) Dim F As Worksheet Dim WS As Worksheet Dim rowNumber As Long Dim cellValue As String '********التحقق من أن النقر كان على الخلية K2 فقط If Not Intersect(Target, Me.Range("K2")) Is Nothing Then Cancel = True Set F = ThisWorkbook.Sheets("إدخال") Set WS = ThisWorkbook.Sheets("نموذج") ' الحصول على قيمة الخلية K2 cellValue = F.Range("K2").Value '*********التحقق مما إذا كانت كلمة "تقديم" موجودة في الخلية K2*** If InStr(cellValue, "تقديم") > 0 Then ' تحديد الصف الأول rowNumber = 2 '******* نسخ البيانات من الصف الأول إلى ورقة "نموذج************ WS.Range("B2").Value = F.Cells(rowNumber, "B").Value WS.Range("H2").Value = F.Cells(rowNumber, "C").Value WS.Range("B7").Value = F.Cells(rowNumber, "D").Value WS.Range("B3").Value = F.Cells(rowNumber, "E").Value WS.Range("G3").Value = F.Cells(rowNumber, "F").Value WS.Range("B4").Value = F.Cells(rowNumber, "I").Value WS.Range("B8").Value = F.Cells(rowNumber, "J").Value WS.Range("E7").Value = F.Cells(rowNumber, "G").Value WS.Range("H7").Value = F.Cells(rowNumber, "H").Value Else MsgBox "كلمة 'تقديم' غير موجودة في الخلية K2.", vbExclamation End If End If End Sub طلب اجازة v1.xlsb

توجيه : واجعل هذا التوجيه حلقة في ودانك .. كما يقول اهلنا في مصر عند انشاء اي جدول يجب اول حقل تعمله هو ID ترقيم تلقائي مفهرس فريد غير قابل للتكرار .. وفي الغالب يكون هو مفتاح الجدول هذا الحقل خاص بجداول اكسس ( اي ملك اكسس ) ولا يرتبط بعلاقات مطلقا .. ولا يظهر للمستخدم مطلقا . قد يستفيد منه المبرمج في حالات نادرة وخاصة فقط . ______________________________________________________________________________________________________ نأتي للعلاقات التي كثيرا ما تشغل فكر المبتدئين : بالنسبة لأعمالي فأنا لا استخدم ربط العلاقات بين الجداول .. ابدا .. الا في حالات نادرة .. وإنما يكون الربط داخل الاستعلامات فقط الحالات النادرة هي : ان يكون الجدولان مصدران لنموذجين منضمين ( رئيسي وفرعي ) السبب في عدم ربط الجداول بالعلاقات هو اني استعيض عن الربط بتوظيف مربع التحرير في النموذج المرتبط بالجدول الفرعي بدلا من الحقل النصي لأن مربعات التحرير محكومة بقيمة محددة تمثل القيمة في الجدول الرأس .. اما الحقول النصية فهي قابلة لإدخال قيم مختلفة وهذا يعني عند استخدام الحقل النصي في النموذج المرتبط بجدول فرعي هنا يجب ربط العلاقة بين الجدولين حتى لا يسمح بادخال قيمة مختلفة __________________________________ نأتي الآن على مثالك تطبيق لماذكرته اعلاه عن مفاتيح الجدول تجد في جدول التفاصيل ( tblMain ) ان المفتاح في الجدول تم توزيعه على حقلي الاسم و المنصب من اجل لا نسمح بتكرار ادراج اسم الموظف بالنمصب نفسه .. ولكنه قد يحصل على ترقية الى منصب آخر وهنا يكون الجدول مصدر بيانات تاريخية يمكنك الاطلاع على تدرج الموظف في المناصب ( وهذا اجتهادا مني ) ويمكنك اعادة المفتاح الى حقل الــــ ID مثال4.rar

شكر وتقدير واحترام

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

بارك الله فيك وجعله في ميزان حسناتك

وعليكم السلام ورحمة الله تعالى وبركاته اخي طريقة تصميمك للملف وكثرة الخلايا المدمجة وتنسيق عرض الصفوف ربما سوف يسبب لك عائق لظهور النتائج بشكل صحيح خاصة عند استخدام الاكواد على العموم لقد قمت بانشاء كودين لنفس المهمة واحد لاستخراج النتائج بالطريقة المطلوبة والاخر لاستخراجها على ورقة اخرى وتنسيقها يمكنك اختيار ما يناسبك Sub Collection_of_books() ' استخراج في ورقة RS_ST_196 Dim WS As Worksheet, i As Long, lr As Long Dim lastRow As Long, n As String Dim studentName As String, ling As Long Dim bookName As String Dim bookNumber As Variant Dim startRow As Long Application.ScreenUpdating = False Set WS = ThisWorkbook.Sheets("RS_ST_196") lastRow = WS.Cells(WS.Rows.Count, "AK").End(xlUp).row WS.Range("BC19:BD" & WS.Rows.Count).ClearContents ling = 19 For i = 18 To lastRow If Not WS.Rows(i).Hidden Then studentName = WS.Cells(i, "AK").Value If InStr(studentName, "اسم الطالب: ") = 1 Then studentName = Trim(Mid(studentName, Len("اسم الطالب: ") + 1)) n = "" startRow = i + 2 Do While WS.Cells(startRow, "AB").Value <> "" bookName = WS.Cells(startRow, "AB").Value bookNumber = WS.Cells(startRow, "AN").Value If WS.Cells(startRow, "AB").Value <> "اسم المقرر" And _ Not IsEmpty(bookNumber) Then If n = "" Then n = bookName Else n = n & " + " & bookName End If End If startRow = startRow + 1 Loop WS.Cells(ling, "BD").Value = studentName WS.Cells(ling, "BC").Value = n ling = ling + 1 End If End If Next i lr = WS.Cells(WS.Rows.Count, "BD").End(xlUp).row With WS.Range("BC19:BD" & lr) .MergeCells = False .HorizontalAlignment = xlCenter .VerticalAlignment = xlCenter .WrapText = True End With Application.ScreenUpdating = True MsgBox "تم تجميع أسماء الطلاب والكتب بنجاح", vbInformation End Sub Sub Collection_of_books_Sheet1() 'Sheet1 نسخ على ورقة Dim WS As Worksheet, dest As Worksheet Dim lastRow As Long, i As Long Dim studentName As String, bookName As String, n As String Dim bookNumber As Variant, row As Range, lr As Long Dim startRow As Long, ling As Long, bCount As Integer Dim r As Long Application.ScreenUpdating = False Set WS = ThisWorkbook.Sheets("RS_ST_196") Set dest = ThisWorkbook.Sheets("Sheet1") lastRow = WS.Cells(WS.Rows.Count, "AK").End(xlUp).row dest.Range("A2:C" & dest.Rows.Count).ClearContents ling = 2 For i = 18 To lastRow If Not WS.Rows(i).Hidden Then studentName = WS.Cells(i, "AK").Value If InStr(studentName, "اسم الطالب: ") = 1 Then studentName = Trim(Mid(studentName, Len("اسم الطالب: ") + 1)) n = "" bCount = 0 startRow = i + 2 Do While WS.Cells(startRow, "AB").Value <> "" bookName = WS.Cells(startRow, "AB").Value bookNumber = WS.Cells(startRow, "AN").Value If WS.Cells(startRow, "AB").Value <> "اسم المقرر" And _ Not IsEmpty(bookNumber) Then If n = "" Then n = bookName Else n = n & " + " & bookName End If bCount = bCount + 1 End If startRow = startRow + 1 Loop dest.Cells(ling, "A").Value = studentName ' اسماء الطلاب dest.Cells(ling, "B").Value = n ' تجميع الكتب dest.Cells(ling, "C").Value = bCount ' عدد الكتب لكل طالب ling = ling + 1 End If End If Next i lr = dest.Cells(dest.Rows.Count, "A").End(xlUp).row With dest.Range("A2:C" & lr) .Borders.LineStyle = xlNone .MergeCells = False .HorizontalAlignment = xlCenter .VerticalAlignment = xlCenter .WrapText = True r = dest.Cells(2, dest.Columns.Count).End(xlToLeft).Column Range(dest.Cells(2, 1), dest.Cells(lr, r)).Borders.Weight = xlThin For Each row In .Rows row.RowHeight = 35 Next row End With Application.ScreenUpdating = True MsgBox "تم تجميع أسماء الطلاب والكتب بنجاح", vbInformation End Sub يمكنك الغاء علامة (+) الموجودة بين الاسماء بتعديل هدا السطر n = n & " + " & bookName الى n = n & " " & bookName RS_ST_196 V2.xls

النماذج الفرعية: لكل نسخة من النموذج AccTree سيكون هناك نسخة مستقلة من النماذج الفرعية التلاعب بالقيم: يؤثر فقط على النسخة التي تعمل عليها clnClient.Add: يستخدم لتخزين النماذج المفتوحة بحيث يمكن الوصول إليها لاحقا باستخدام معرف النافذة المتغيرات: يمكن استخدام نفس المتغير لإدارة جميع النماذج أو يمكن تعريف متغيرات منفصلة حسب الحاجة

Sub CopyData() Dim src As Worksheet, dest As Worksheet Dim Clé As String, foundCell As Range Dim tmp As Long Dim cnt As Boolean Dim i As Integer Dim sumRange As Range Dim totalCell As Range Set src = ThisWorkbook.Sheets("ورقة1") Set dest = ThisWorkbook.Sheets("ورقة2") ' الحصول على القيمة من الخلية D3 Clé = src.Range("D3").Value ' التحقق من إدخال قيمة في الخلية D3 If Clé = "" Then MsgBox "يرجى إدخال الرقم الخاص", vbExclamation Exit Sub End If ' تحديد نطاق البحث والعثور على الخلية 'ورقة1 (D)' الى اخر خلية بها بيانات في عمود Set srcRng = src.Range("D11:D" & src.Cells(src.Rows.Count, "D").End(xlUp).Row) Set foundCell = srcRng.Find(What:=Clé, LookIn:=xlValues, LookAt:=xlWhole) ' التحقق من العثور على القيمة If Not foundCell Is Nothing Then tmp = foundCell.Row ' التحقق من وجود بيانات في الصف cnt = False For i = 7 To 18 If src.Cells(tmp, i).Value <> "" Then cnt = True Exit For End If Next i If cnt Then ' مسح محتويات عمود (J) في ورقة 2 dest.Range("J9:J" & dest.Rows.Count).ClearContents ' نسخ البيانات إلى عمود (J) For i = 7 To 18 dest.Cells(9 + (i - 7), 10).Value = src.Cells(tmp, i).Value Next i dest.[F2].Value = src.Cells(tmp, 3).Value dest.[F3].Value = Clé ' حساب مجموع القيم في العمود (J) وإدخاله في الخلية F4 و j21 Set sumRange = dest.Range("J9:J20") Set totalCell = Union(dest.Range("F4"), dest.Range("j21")) totalCell.Value = Application.WorksheetFunction.Sum(sumRange) MsgBox "تم نسخ البيانات بنجاح ", vbInformation Else MsgBox "خلايا التقييم فارغة", vbExclamation End If Else MsgBox "لم يتم العثور على الرقم الخاص", vbCritical End If End Sub تقييم v3.xlsb

يمكنك دالك بدون الحاجة لاظافة اي اكواد جديدة فقط قم بتسمية عنصر Combobox2 طبقا لتسلسل عناصر textbox الموجودة مسبقا على الفورم اي (TEXTBOX62) وتعديل هدا السطر Const dict As Integer = 61 ليصبح بعدد العناصر الموجودة Const dict As Integer = 62 1 ترحيل مع كمبوبوكس.xlsm

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

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

الاستاذ الجليل صاحب المكتبة العامرة @Moosak انت مبدع وعبقرى ما شاء الله تبارك الله تسلم ايدك اسأل الله أن يديم عليكم الصحة والعافية وأن يحفظكم من كل سوء ومكروه ويبارك فيكم وفي أرزاقكم ويسهل لكم اموركم وان يحسن لكم القضاء ويبعد عنكم الشقاء ولا يمر عليكم يوم إلا وأنتم في نعمة وصحة وعافية اللهم آمين يارب العالمين 🤲

مجهود جبار جعله الله فى ميزان حسناتك