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

تفضل اليك الحلول التالية Sub ترحيل1() Dim Cpt As Long, Arr As Range, r As Range Dim a As Worksheet: Set a = Worksheets("Home"): Dim F As Worksheet: Set F = Worksheets("data") Cpt = F.Cells(F.Rows.Count, "B").End(xlUp).Row With Application .Calculation = xlManual .ScreenUpdating = False b = Array(a.[B2], a.[B3]): c = a.[F5] d = Array(a.[B4], a.[B5], a.[D2], a.[D3], a.[D4], a.[D5], a.[F2], a.[F3], a.[F4]) '***لعدم الترحيل في حالة العثور على خلية فارغة*** 'Set Arr = Union(a.[B2:B5], a.[D2:D5], a.[F2:F5]) ' For Each r In Arr ' If IsEmpty(r.Value) Or r.Value = vbNullString Then ' MsgBox " المرجوا ملء بيانات " & r.Offset(0, -1).Value, vbExclamation, "إنتباه" ' Exit Sub ' End If ' Next r '************************************************ F.Cells(Cpt + 1, "A") = F.Cells(Cpt + 1, "A").Row - 2 F.Cells(Cpt, "B").Offset(1).Resize(, 2).Value = b F.Cells(Cpt, "E").Offset(1).Resize(, 9).Value = d F.Cells(Cpt, "O").Offset(1).Value = c .Calculation = xlAutomatic .ScreenUpdating = True End With MsgBox "تم ترحيل البيانات بنجاح", vbInformation End Sub او Sub ترحيل2() Dim Cpt As Long Dim a As Worksheet: Set a = Sheets("Home"): Dim F As Worksheet: Set F = ThisWorkbook.Sheets("data") Cpt = F.Cells(F.Rows.Count, "B").End(xlUp).Row + 1 With Application .Calculation = xlManual .ScreenUpdating = False Arr = Array(a.[B2], a.[B3], a.[B4], a.[B5], a.[D2], a.[D3], a.[D4], a.[D5], a.[F2], a.[F3], a.[F4], a.[F5]) For I = 0 To 11 If Arr(I) = Empty Then MsgBox " المرجوا ملء بيانات " & Arr(I).Offset(0, -1), vbExclamation, "إنتباه" Exit Sub End If Next F.Cells(Cpt, "A") = F.Cells(Cpt, "A").Row - 2 F.Cells(Cpt, "B").Value = a.[B2].Value: F.Cells(Cpt, "G").Value = a.[D2].Value F.Cells(Cpt, "C").Value = a.[B3].Value: F.Cells(Cpt, "H").Value = a.[D3].Value F.Cells(Cpt, "E").Value = a.[B4].Value: F.Cells(Cpt, "I").Value = a.[D4].Value F.Cells(Cpt, "F").Value = a.[B5].Value: F.Cells(Cpt, "J").Value = a.[D5].Value F.Cells(Cpt, "K").Value = a.[F2].Value: F.Cells(Cpt, "L").Value = a.[F3].Value F.Cells(Cpt, "M").Value = a.[F4].Value: F.Cells(Cpt, "O").Value = a.[F5].Value .Calculation = xlAutomatic .ScreenUpdating = True End With MsgBox "تم ترحيل البيانات بنجاح", vbInformation End Sub 2024-3-15 ترحيل V2.xlsm

طيب استاذنا @Ahmed_J جرب الشيفرة ان شاء الله تلبي طلبك ...... Dim db As DAO.Database Dim rs As DAO.Recordset Dim i, ii, R, Grad As Integer Dim numCopies As Integer Set db = CurrentDb Set rs = db.OpenRecordset("SELECT tp2.GradeNO, tp2.سنوات_المكوث FROM tp2 WHERE (((tp2.GradeNO)<=" & Me.الدرجة_الوظيفية & ")) ORDER BY tp2.GradeNO DESC;", dbOpenDynaset) ii = Me.iYear R = 0 Do Until rs.EOF numCopies = rs!سنوات_المكوث For i = 1 To numCopies If ii = 0 Then Me.مربع_تحرير_وسرد47 = Grad Me.مربع_تحرير_وسرد49 = Me.المرحلة_الوظيفية + R Exit Sub End If ii = ii - 1 Grad = rs!GradeNO Next i R = R + Me.iYear - rs!سنوات_المكوث rs.MoveNext Loop rs.Close Set rs = Nothing Set db = Nothing

ان شاء الله هيعمل على office 2010 Dim cellState As New Collection Private Sub Workbook_Open() Dim ws As Worksheet Dim cell As Range For Each ws In ThisWorkbook.Worksheets For Each cell In ws.UsedRange If Not IsEmpty(cell.Value) Then cellState.Add cell.Value, cell.Address End If Next cell Next ws End Sub Private Sub Workbook_BeforeClose(Cancel As Boolean) cellState.Clear End Sub Private Sub Worksheet_Change(ByVal Target As Range) Dim cell As Range Dim ws As Worksheet Set ws = Target.Worksheet For Each cell In Target If Not Intersect(cell, ws.UsedRange) Is Nothing Then If Not IsEmpty(cell.Value) And cell.Value <> cell.Text Then cell.Interior.Color = RGB(0, 0, 0) ' Black color cell.Font.Color = RGB(255, 255, 255) ' White color If cellState.Contains(cell.Address) Then cellState.Remove cell.Address End If cellState.Add cell.Text, cell.Address End If End If Next cell End Sub

Public Sub OpenMyForm() DoCmd.OpenForm "types", acNormal End Sub ثم قم بالاستدعاء تحت زر الامر هكذا OpenMyForm

abouelhassan للاسف لم يعمل عندي علما الويندوز عندي 10 والاوفيس 2010 ولا اعرف السبب وعلى العموم انا بشكرك على تعبك معي ورمضان كريم

السلام عليكم استاذي العزيز @Barna خليني اشرح لك : الدرجة الثامنة اعلى بالوظيفة وبالراتب من الدرجة التاسعة وهكذا (اعلى درجة وظيفية عندنا هي الاولى ) وحسب الجدول مثلا موظف حاصل على شهادة البكالوريوس يتم تعيينه في الدرجة الوظيفة السابعة / المرحلة الوظيفية الاولى (يعني 7-1) بعد مرور 4 سنوات خدمة وظيفية يتم ترفيعه الى الدرجة السادسة / المرحلة الاولى يعني (6-1) وهكذا حسب الجدول الموجود في الصورة يعني باختصار (يتم ترفيع الموظف من الدرجة العاشرة الى الدرجة السادسة كل 4 سنوات ومن الدرجة الخامسة الى الدرجة الاولى كل 5 سنوات) --------------------------------------------------------------------------------------------------------------------------------------- المطلوب : توزيع الخدمة_المضافة_سنة مثلا (7) سنوات يتم مقارنتها بالدرجة الوظيفية بالنموذج مع الجدول tp2 (اي لوكان الموظف في الدرجة التاسعة والمرحلة الاولى نضيف له درجة واحدة وثلاث مراحل وظيفية ) لان فترة مكوثه 4 سنوات فتصبح الدرجة الوظيفية الجديدة = 8 والمرحلة الوظيفية الجديدة =4 (اي يتم توزيعها) وهكذا تحياتي

شكرا اخي الفاضل

طيب استاذ @Ahmed_J ممكن شرح ... كيف الموظف كان في التاسعة وصار في الثامنة ... بارك الله فيك ... من امس وانا احاول دبلجتها وما ركبت في رأسي ولا رأس الجهاز ممكن قصدك العاشرة والمرحلة الرابعة

على شريط Excel، انتقل إلى علامة التبويب "الصيغ" > مجموعة الحساب، وانقر فوق الزر "خيارات الحساب" وحدد تلقائي (Automatic)

إنتهاء الرحصة222.xlsm

تفضل <><><><><><><><> قاعدة بيانات مدرسية.accdb

هل هذا طلبك أخي الكريم ، Database1.accdb

العيادة.xlsx

وعليكم السلام ورحمة الله وبركاته تفضل أخي الغالي 1. اضفت بعض الأعمده وبها صيغ لتحسن الشكل ولاستخراج بيانات إضافية. 2. تم عمل ما طلبت ولكني حسبت السنة على 360 يوم كالمعتاد في حسابات المؤسسات لحساب بدل الأجازات ونهايو الخدمة رصيد الاجازات بالأيام.xlsx

ربما هدا ما تقصده تجربة فرز الرواتب.xlsx

السلام عليكم هل يمكن تنفيذ هذه الفكره لملف للاقساط الفكره مثلا عدد الاقساد 5 قيمه القسط 100 ميعاد القسط الاول 15/1/2024 ميعاد القسط الثانى 15/2/2024 وهكذا ولكن عند التأخر فى سداد القسط تحسب فائدة على القسط المتأخر فى السداد عند سداد اقل من قيمه القسط تحسب فائدة على الباقى من القسط فقط اظهار باقى الملبغ المتبقى من الاقساط المصنف2.xlsx

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

اعتقد هذا طلبك Update Prog.mdb

اتمنى اني اكون فهمت صح 😅 تفضل هذه الفكرة Prog.accdb

هذه الفكرة شريط تحميل يظهر لك وكأنه تحميل حقيقي ، يتمد على الوقوف العشوائي في كل مرة يتم فيها تشغيل الشريط ؛ طبعاً بالإعتماد على موديول RandomX وموديول Sleep ، وكنت استعمله في فكرة مسح الجداول من البيانات ( إعادة ضبط المصنع للقاعدة وإفراغ جداولها من البيانات ) طبعا كمثال وتشغيل استعلامات الحذف تبعاً لكل تغيير نص. هي كفكرة تستطيع تطويرها ، واعتقد ستجد مشاركات أفضل منها بكثير 😊 Prog.accdb

ولاثراء الموضوع ايضا ... والاشتراك مع الاساتذة الكرام في هذا الشعور والتعاون الاكثر من رائع اليكم الرابط التالي http://www.officena....ndpost&p=223202 وهو من احد ابداعات الأستاذ ابو نصار ( العيدروس ) الذي نفتقده منذ فترة به كود لازالة المسافات الزائدة بين الكلمات لأكثر من مسافه واحدة و ازالة المسافات في نهاية الإسم ارجو ان يفيد تقلبوا خالص تحياتي

السلام عليكم ورحمة الله وبركاته بعد اذن الاستاذة الفاضلة أم عبدالله والاستاذ الفاضل سليم حاصبيا لاثراء الموضوع حل آخر عن طريق الاكواد الملف المرفق يتم حذف اي مسافات بالعمود الذي تحدده ملحوظة :- الكود ليس لي ولكن محمل من المنتدي سابق ولا اتذكر من صاحبه تحياتي لكم جميعا حذف المسافات الزائدة_W.rar