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

هنا الحل Mod 2 = 1 Mod 2 <> 0

السلام عليكم هذا البرنامج عملته من سنين ، حين كنت اعمل في مكتبة المدرسة برنامج مكتبة مدرسية شامل 1- تسجيل الكتب وتوصيفها 2- تسجيل الطلاب 3- شاشة احترافية لإعارة الكتب واسترجاعها باستخدام قارىء الباركود ، أو باستخدام ادخال رقم الكتاب ورقم الطالب 4 - تقارير متنوعة شاملة 5- محاولة لتفعيل جهاز البصمة للزوار لم تكتمل بعد وميزات اخرى تجدونها عند تجربة البرنامج ارجوا ممن يستفيد منه الا ينساني من دعوة في ظهر الغيب . mktbah.rar

للفائدة : Long Text = Memo وبالعربي : مذكرة أو مفكرة

يمكن الخروج من هذا التعقيد كله بطريقة سهلة 🙂 وذلك بجعل حقل النص من نوع : Long Text وضبط الخيار Text Format إلى : Rich Text ... كما هو واضح في الصورة .. وبعدها ستتمكن من إظهار مربع الخط والألوان بمجرد تظليل النص المراد تنسيقه 🙂 وستتخزن التنسيقات تلقائيا في الجدول .. تنسيق الخط والألوان.accdb

الاصل اخى أن نقوم بتقديم البسيط وإليك المطلوب جرب Dim PreviousValue As Variant Private Sub Worksheet_Change(ByVal Target As Range) On Error Resume Next If Target.Cells.Count > 1 Then Exit Sub If Not Intersect(Target, Me.UsedRange) Is Nothing Then Application.EnableEvents = False If PreviousValue <> Target.Value Then Call LogChanges(Target.Address, PreviousValue, Target.Value) PreviousValue = Target.Value End If Application.EnableEvents = True End If End Sub Sub LogChanges(ByVal TargetAddress As String, ByVal OldValue As Variant, ByVal NewValue As Variant) Dim wsLog As Worksheet Set wsLog = ThisWorkbook.Sheets("Log") With wsLog .Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0).Value = Now .Cells(.Rows.Count, 2).End(xlUp).Offset(1, 0).Value = TargetAddress .Cells(.Rows.Count, 3).End(xlUp).Offset(1, 0).Value = OldValue .Cells(.Rows.Count, 4).End(xlUp).Offset(1, 0).Value = NewValue End With End Sub الآن، قم بإضافة ورقة جديدة في ملف Excel واسمها "Log"، وهذه الورقة ستحتوي على تفاصيل التغييرات. عند كل مرة يتم فيها تغيير قيمة في ورقة العمل، سيتم تسجيل الوقت وعنوان الخلية والقيمة القديمة والجديدة في ورقة "Log". يرجى ملاحظة أنه يمكنك تعديل اسم ورقة العمل التي تحتوي على سجل التغييرات بحسب احتياجاتك.

عملت لك السطر الأعلى من حقول الألوان من اجل تكملي الباقي اذا العمل الحالي موافق لطلبك .. يمكننا نقل النتيجة الى الجدول اكملي كتابة احداث بقية الألوان اذا يمكنك الانتظار يمكن ان نجد حدثا واحدا لكافة حقول الألوان color.accdb

سؤال اخر لو سمحت اخي ماذا لو اردت حذف السجلات برقم فردي

تفضل بالتوفيق Dim strSQL As String ' Replace "YourTableName" with the actual name of your table strSQL = "DELETE FROM TBmast WHERE idmast Mod 2 = 0;" CurrentDb.Execute strSQL MsgBox "تم حذف السجلات ذات الرقم الزوجي بنجاح.", vbInformation Me.Requery mast.accdb

يمكنك استخدام ميزة التعقب التغيرات في Excel لتسجيل التغييرات التي تحدث على الملف. يمكنك اتباع الخطوات التالية: 1. افتح ملف Excel الخاص بك. 2. انتقل إلى علامة التبويب "مراجعة" (Review). 3. انقر على "تعقب التغييرات" (Track Changes). 4. اختر "تعقب التغييرات" (Track Changes). 5. في النافذة التي تظهر، حدد الخيارات التي تريدها، مثل تعقب الخلايا المحددة أو جميع الخلايا في الورقة. 6. انقر على "موافق" (OK) لتفعيل التعقب. 7. سيظهر Excel الآن رسالة تطلب منك حفظ الملف لتمكين التعقب. اضغط "موافق" (OK) لحفظ الملف. عندما يتم الآن إجراء أي تغييرات على الملف، ستظهر تلقائياً في صفحة جديدة تحت علامة التبويب "مراجعة" (Review) بعنوان "مسار التغييرات" (Changes History). احترامي وتقديري لك

جاري العمل واليك ماتوصلت اليه للحين . سامحني على التأخير . DDTest481-1.rar

تقضل استاذ @hani-arniat محاولتي . ولا تنسى اذا كان هذا طلبك الضغط على أفضل اجابة . Search By code.rar

استاذ @سامر محمود مبدئياً جرب النموذج المرفق ... هل به نواقص أو زيادات أو تريد شيء أخر لأن هذا بيتبني عليه الباقي . DDTest481.rar

نيابة عن اخي موسى استبدل السطر الاخير من الكود بهذا لإدراج السنة ضمن الشرط : DoCmd.OpenForm "Frm_VermLoans", , , "month([Auto_Date]) & year([Auto_Date])=" & Month([TxtMonth]) & Year([TxtMonth])

جرب Private Sub UserForm_Initialize() Dim ws As Worksheet Dim lastRow As Long Dim i As Long ' تحديد ورقة العمل التي تحتوي على البيانات Set ws = ThisWorkbook.Sheets("Sheet1") ' قم بتغيير اسم الورقة حسب اسم ورقتك ' احتساب عدد الصفوف الممتلئة في العمود A lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row ' تحميل البيانات إلى ListBox وتنسيقها For i = 2 To lastRow ' افترضنا هنا أن البيانات تبدأ من الصف 2، يمكنك تغيير الرقم إذا لزم الأمر ListBox1.AddItem Format(ws.Cells(i, 1).Value, "0.000") ' المبيعات ListBox1.List(ListBox1.ListCount - 1, 1) = Format(ws.Cells(i, 2).Value, "0.000") ' العمولة ListBox1.List(ListBox1.ListCount - 1, 2) = Format(ws.Cells(i, 3).Value, "0.000") ' صافي المبيعات Next i End Sub Private Sub ListBox1_Click() Dim selectedRow As Long ' الحصول على الصف المحدد في ListBox selectedRow = ListBox1.ListIndex ' التحرك إلى الخلية المقابلة في ورقة العمل If selectedRow >= 0 Then ThisWorkbook.Sheets("Sheet1").Cells(selectedRow + 2, 1).Select ' نفترض أن البيانات تبدأ من الصف 2 End If End Sub

جرب Sub نقل_البيانات() Dim ws As Worksheet Dim wsResult As Worksheet Dim lastRow As Long Dim i As Long Dim nextRow As Long ' افتح ورقة العمل الحالية Set ws = ThisWorkbook.Sheets("Sheet1") ' استبدل "Sheet1" باسم ورقة العمل الخاصة بك ' قم بإنشاء ورقة النتيجة إذا لم تكن موجودة بالفعل On Error Resume Next Set wsResult = ThisWorkbook.Sheets("النتيجة هنا") On Error GoTo 0 If wsResult Is Nothing Then Set wsResult = Sheets.Add(After:=Sheets(Sheets.Count)) wsResult.Name = "النتيجة هنا" End If ' حساب آخر صف غير فارغ في عمود F lastRow = ws.Cells(ws.Rows.Count, "F").End(xlUp).Row ' نقل البيانات إلى ورقة النتيجة باستثناء الأسطر الفارغة في عمود F nextRow = 1 ' الصف التالي المتاح في ورقة النتيجة For i = 1 To lastRow If ws.Cells(i, "F").Value <> "" Then ws.Rows(i).Copy wsResult.Rows(nextRow) nextRow = nextRow + 1 End If Next i MsgBox "تم نقل البيانات بنجاح!" End Sub

جرب Sub InsertPageBreaks() Dim ws As Worksheet Dim rowsPerPage As Integer Dim lastRow As Long Dim i As Long ' تعيين عدد الصفوف في كل صفحة rowsPerPage = 24 ' تحديد الورقة التي ترغب في تطبيق الفواصل عليها Set ws = ThisWorkbook.Sheets("Sheet1") ' تغيير "Sheet1" إلى اسم الورقة الخاصة بك ' حذف الفواصل الحالية إن وجدت ws.ResetAllPageBreaks ' الحصول على آخر صف غير فارغ في الورقة lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row ' إدراج فواصل الصفحات بعد كل rowsPerPage صف For i = rowsPerPage To lastRow Step rowsPerPage ws.Rows(i).PageBreak = xlPageBreakManual Next i End Sub قم بتغيير "Sheet1" في السطر Set ws = ThisWorkbook.Sheets("Sheet1") إلى اسم الورقة التي ترغب في تطبيق الفواصل عليها. قم بتعديل قيمة rowsPerPage إلى العدد المطلوب من الصفوف في كل صفحة.

استاذ khaled_1960 انا لم استفاد نهائيا من هذا الملف لاني حضرتك قافل ال vba بباس ورد - برجاء فتحه أو لا حاجه لرفعه اصلا لاننا مش هنستفاد ؟؟؟

الاسم : محمد طاهر سنة الميلاد : 1968 م المهنة : مهندس مدني و أعمل فى مجال إدارة المشاريع الهندسية التعليم : بكارولويس هندسة مدنية 1991 - هندسة القاهرة ماجيستير إدارة مشروعات 1998 - هندسة القاهرة PMP 2008 RMP 2012 MVP 2010-2013 الحالة الاجتماعية : متزوج و رزقني الله ب 4 أطفال بلد الجنسية / بلد الاقامة : مصر / الامارات أقسام الاهتمام فى المنتدي : كل الأقسام - و بالذات الأكسيس و الإكسيل معلومات أخري : أحب الأكسس و أنشأت تطبيقات مختلفة له ، و أيضا أحب جدا الاكسيل و استخدام ال vba به . تتركز خبرتي فى مجال ادارة المشاريع عموما و مشاريع التشييد بصفة خاصة، و لدى خبرة عملية فى هذا المجال من حيث التطبيق و التدريب. أجيد إستخدام برامج ادارة المشروعات بالاضافة الي بعض البرامج الهندسبة و أستخدم بعض برامج الرسم و الجرافيك بصورة متوسطة. و لدي دراية بسيطة بتصميم الويب و لغاته . خبرتي فى المنتديات : عضو شرف و مشرف قسمي الأكسس و الأوفيس ( سابقا ) و مراقب سابق فى الفريق العربي للبرمجة و إفتتحت هذا الموقع رسميا فى فى الثاني من جمادي الأولي 1424 هـ الموافق أول يوليو 2003 مـ

اعتذر عن الانقطاع لظروف مرضية ان شاء الله سوف نبدأ فى الاستمرار تباعا بامر الله