اذهب الي المحتوي
أوفيسنا
بحث مخصص من جوجل فى أوفيسنا
Custom Search

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

Popular Content

Showing content with the highest reputation since 28 فبر, 2024 in مشاركات

  1. السلام عليكم ورحمة الله وبركاته أسعد الله أوقاتكم بكل خير وسرور .. وتقبل الله منا ومنكم صالحات الأعمال .. 😊🤲🏻 يطيب لي أن أقدم لكم هذا الهدية المتواضعة بمناسبة هذا الشهر الفضيل 🙂🌼🎁 استبدل الرسائل العادية في أكسس برسائل ذات تصاميم قمة في الإبداع وبمميزات إضافية . من مميزات هذه الرسائل: - تصميم جميل وألوان جذابة. - خاصية ذاتية الاختفاء. - عنوان رئيسي + عنوان فرعي - تحكم بالنص ( عربي - إنجليزي ) ( توسيط - محاذاة على اليمين أو اليسار) - سهلة الاستخدام . الشرح على اليوتيوب : التحميل 🙂 Moosak MsgBox.accdb ولا تنسوني من صالح دعواتكم 😊🌷🌼🌹
    9 points
  2. السلام عليكم ورحمة الله وبركاته ، أخواني وأساتذتي ومعلمينا ( دون استثناء ) لكثرة الطلبات على برنامج إدارة الحضور والإنصراف للموظفين ، وددت مشاركتكم النسخة الأولى الغير مفتوحة المصدر حالياً ، لحين الإنتهاء من التعديلات التي ستتم على البرنامج . دون الإطالة في المقدمة ؛ سأشرح لكم بعض ميزات البرنامج :- أولاً سيتم إضافة الإعدادات الضرورية للبرنامج وهي :- تصنيف الموظفين ( ولكل تصنيف سيتم تحديد عدد أيام الإجازات السنوية له ) . تصنيف الإجازات ( طارئة ، مرضية ، ..... إلخ ) . تحديد وقت بداية ونهاية ساعات العمل الرسمي ، و تحديد مدة السماح للتأخير ( المرونة في العمل ) ، تحديد عدد مرات التأخير ليتم احتساب يوم إجازة في اليوم الأخير من المدة . ثانياً ومن الطبيعي وجود موظفين في قاعدة البيانات ، سيكون قسم لإدخال بيانات الموظفين بشكل بسيط من المعلومات ( ولكم حرية التوسع حسب رغبتكم وحاجتكم كمستخدمين ) ، وطبعاً لكل موظف رقم وظيفي خاص به اعتمد على سلسلة مكونة من التاريخ والوقت الحالي بدون مسافات بهذا التنسيق YYYYMMDDhhmmss ، بحيث لا يكون هناك تكرار نهائي لأي رقم موظف . ثالثاً لوحة تسجيل الحضور والإنصراف عن طريق الرقم الوظيفي ، وتدعم القراءة من الباركود الموجود على باجة الموظف ( طبعاً لاحقاً سيتم إضافة طباعة باجة أو بطاقة للموظف ) ، وفي هذه اللوحة لن تحتاج تحديد الحالة ( حضور أو إنصراف ) فقط أدخل رقم الموظف وسيتم احتساب وقت الحضور وتسجيل مدة التأخير بالدقيقة في الجدول ، وكذلك الأمر للإنصراف . رابعاً لوحة تسجيل الإجازات ، وطبعاً بناءً على المعطيات التي تم إدخالها في نماذج البيانات الأساسية في الإعدادات - سيكون الأمر بسيطاً جداً وتم اعتماد رقم الموظف في المرحلة الأولى من البرنامج وسيتم اعتماد اسم الموظف أيضاً لجلب البيانات لاحقاً . بخطوات بسيطة بعد ادخال رقم الموظف نحدد تاريخ بداية الإجازة ، ثم عدد الأيام المطلوبة كإجازة ، ثم سيتم تلقائياً احتساب يوم نهاية الإجازة ، وطبعاً نوع الإجازة المطلوبة ستقوم باختياره من قائمة نوع الإجازة . خامساً لوحة التقارير ، بحيث سيكون لدينا في المشروع تقرير واحد فقط لكنه سيخدم جميع الطرق التي تريدها كمستخدم ( تقرير للموظفين جميعاً مع وبدون تحديد فترة ، تقرير لموظف واحد مع وبدون تحديد فترة ) . *وطبعاً ما زالت قيد التطوير بشكل خاص ملاحظة:- تم حفظ البرنامج بصيغة Accde كونه قيد التطوير والتعديل حالياً
    7 points
  3. ما فيه .. هذا حمود وهذي عباته لما طلع vb6 من بيتهم القديم وطلع يجدد بيته .. اكسس حل محله وجلس في البيت القديم
    6 points
  4. استاذ @gavan من وجهة نظري كل البرامج تعتمد على تقسيم القاعدة . فأنت هنا بالاكسس يمكنك تقسيم القاعدة أماميه وبها (الاستعلامات والنماذج و التقارير و الموديلات و الوحدات النمطية)، والقاعدة الخلفية وبها الجداول وممكن تقسم القاعدة الخلفية كمان مجموعة جداول بقاعدة والمجموعة الباقية بقاعدة أخرى والربط بين القاعدة الأمامية والقواعد الخلفية بالطريقة السليمة . تحياتي .
    5 points
  5. ادخال معلومات بالاختيار من ليست بوكس للجدول واصدار تقرير متعدد الاختيارات . المرفق متاح ومفتوح المصدر لكل مايريد استخدامه أو استخدا مابه ... DDChoseMulty Items to Report.rar
    5 points
  6. السلام عليكم ورحمة الله وبركاته اخواني الكرام.. قرأت أكثر المواضيع التي تتعلق بموضوع الباركود والـ QR . إلا انني أبحث عن شيء محدد ، ولا أخفيكم أنني حاولت ابتكار فكرة تعمل بشكل عكسي تقوم على مبدأ أنه عند قراءة الباركود داخل آكسيس يقوم بإدراج البيانات من الباركود الى مربعات نص محددة. على سبيل المثال ( تمت التجربة على QR ):- ( رقم المريض ، اسم المريض ، رقم الهاتف ، العمر ) هذه المعلومات تمت إضافتها في QR وانشاء صورة . المطلوب أنه عند قراءة هذا الـ OR في النموذج ان يتم ادراج القيم في مربعات النص التي يتم تحديدها ( علماً بأن النموذج هذا ليس له مصدر بيانات جدول او استعلام وغير مطلوب حفظ القيم داخل اي جدول . وهذه صورة QRتحتوي العديد من البيانات للتجربة لم أقم بارفاق ملف لأنني رغبت بان يكون الموضوع مفتوح بأكثر من اتجاه وليس ضمن فكرة محددة . المطلوب :- طريقة تجعلني عند قراءة الباركود ان يتم ادراج البيانات التي يحملها في مربعات نص محددة !!
    4 points
  7. Dim db As DAO.Database Dim rs As DAO.Recordset Dim fld As DAO.Field Dim searchNumber As Long Dim found As Boolean searchNumber = Me.C Set db = CurrentDb() Set rs = db.OpenRecordset("SELECT Salary.GradeNO, Salary.[1], Salary.[2], Salary.[3], Salary.[4], Salary.[5] FROM Salary ORDER BY Salary.GradeNO DESC;", dbOpenDynaset) i = 0 found = False Do Until rs.EOF For Each fld In rs.Fields If Not IsNull(fld.Value) And fld.Value = searchNumber Then found = True ElseIf found And Not IsNull(fld.Value) And i < Me.D And fld.Name <> "GradeNO" Then i = i + 1 Me.G = fld.Value Me.E = rs!GradeNO Me.F = fld.Name End If Next fld rs.MoveNext Loop rs.Close Set rs = Nothing Set db = Nothing
    4 points
  8. استكمالا لكيفية التحديث بطريقة أخرى بعد الشكر لمساعدتكم في طرح الأفكار سوف أقدم لكم هذه الطريقة وقبل البدأ اريد ان أنوه على بعض الردود حول الجداول في قاعدة البيانات هل أقوم بإعادة ربطها بعد التحدث والجواب هو (لا) وذلك عند تحديث البرنامج اقوم بإعادة ربطها من جهاز المطور وكل أجهزة المستخدمون والسيرفر وجهازي اللي أطور البرنامج عليه مرتبطة بشبكة محلية داخل الشركة وبعد التحديث وعند تركيب البرنامج على أي جهاز فإن الجداول تتصل بقاعدة البيانات مباشرة . سوف أشرح الفكرة باختصار المتطلبات 1- جدول جديد يضاف في البرنامج مرتبط بقاعدة البيانات مباشرة يحتوي على حقل رقم النسخة 2- تصميم نموذج افتتاحي مصدره الجدول السابق 3- تصميم برنامج مساعد نسميه (Update.accdb ) ونضعه في مجلد البرنامج 4- مجلد مشاركة موجود على السيرفر نضع فيه البرنامج المحدث شرح خطوات البرنامج عند التحديث 1- عند اكتمال التحديث يضاف رقم النسخة الجديدة في النموذج على سبيل المثال (002) في النموذج الافتتاحي و في الجدول رقم النسخة 2-عند التشغيل يقوم البرنامج بمقارنة النسخة المخزنة في الجدول مع جدول حقل النسخة ، سوف يجد الاختلاف وتظهر رسالة يوجد تحديث 3- يغلق البرنامج (الاصدار القديم) ويفتح البرنامج المساعد 4- عند فتح البرنامج المساعدة يقوم بحذف النسخة القديمة ويستدعي النسخة الجديدة من مجلد المشاركة على السيرفر ويلصقها في نفس مجلد البرنامج بدل النسخة القديمة التفاصيل من المعروف أن البرنامج سوف يكون على الهاردسك ( C ) عند جميع المستخدمون في المجلد (Shaoon) وأيضا البرنامج المساعد (Update.accdb) وملحقات البرنامج مثل أيقونة البرنامج او ملفات التعليمات وغيرها 👇 النموذج الافتتاحي في البرنامج عند المستخدم ذو الاصدار 001 👇 النموذج الافتتاحي في البرنامج الوسيط ( Update.accdb ) 👇 انتهى الشرح في المرفق الشرح العملي ملاحظة هامة : عند تنزيل الشرح العملي فك الضغط وضع الثلاثة المجلدات في البارتشن (C) مباشرة ومن ثم الدخول على المجلد (Shaoon) وتشغيل البرنامج (Shaoon.accdb) Program.rar
    4 points
  9. وعليكم السلام ورحمه الله وبركاته جرب هذا التعديل كود عمل فورمات للخلية عند التعديل.xlsm
    4 points
  10. تفضل <><><><><><><><> قاعدة بيانات مدرسية.accdb
    4 points
  11. تفضل احذف الكود الخاص بك الموجود في حدث الشيت ثم ضع هذا الكود Private Sub Worksheet_Change(ByVal Target As Range) Dim X As Range Application.EnableEvents = False For Each X In Target If X.Column = 2 Then If X.Value = "" Then X.Resize(, 6).ClearContents Else X.Offset(0, 2) = Date X.Offset(0, 2).NumberFormat = "dddd yyyy/mm/dd" End If End If Next Application.EnableEvents = True Search_SUM End Sub
    4 points
  12. وعليكم السلام ورحمة الله وبركاته اليك الحل ان شاء الله ولكن ياريت في المرات القادمة ارفاق النمطلوب في ملف الإكسل تلوين خلية.xlsx
    4 points
  13. ربما هدا ما تقصده تجربة فرز الرواتب.xlsx
    4 points
  14. وعليكم السلام ورحمة الله وبركاته تفضل اخى تقسيم الاسم على اربعة اعمدة لاول اربعة اسماء تقسيم الاسم الرباعى الى اربعة اسماء منفصلة.xlsm
    4 points
  15. بارك الله فيك ..... انظر الصورة لهذا الموظف قبل التحديث وبعد التحديث ( هل هذا هو المطلوب ) ؟؟؟؟؟؟ جرب المرفق واعلمنا بالنتيجة ..... الغياب والتاخير.accdb
    4 points
  16. ومشاركة مع أستاذنا ابو خليل فصل العدد الكسري.accdb
    4 points
  17. وعليكم السلام ورحمة الله وبركاته تفضل حل متواضع بالمعادلات ويمكن التنفيذ للحل بالأكواد يمكن البحث داخل المنتدى عن استدعاء وترحيل البيانات نموذج أوفيسنا 002.xlsm
    4 points
  18. علم البرمجة 80% ممارسة .. و 20% دراسة نظرية الدراسة النظرية المكثفة مع ممارسة قليلة .. نهايتها النسيان الأشياء التي ترسخ بالذاكرة هي الاشياء التي تكتشفها او تصل اليها بالمحاولة والخطأ منتدى اكسس اوفيسنا هو اكبر صرح تعليمي على مستوى الوطن العربي .. وبالمجان اذا اتبع الشخص طرق التعلم الصحيحة من الصفر .. سوف يصل الى الاحتراف في مدة وجيزة الطريقة .. هي بناء مشروع يكون هو فعلا بحاجته .. او بتكليف من شخص آخر يحتاجه لأن التعلم من اجل التعلم فقط تضعف الهمة فيه غالبا وهذا شيء مجرب .. بسبب فقد الحافز
    4 points
  19. وعليكم السلام ورحمة الله نعالى وبركاته اظن انه يجب عليك اولا تغيير مكان خلية اختيار اسم المادة (N1) خارج نطاق البحث لانه في حالة تم اخفاء عمود مادة الدين مثلا عمود (N) سيتم اخفاء خلية الاختيار لنفترض ان الخلية المحددة هي (R1) Private Sub Worksheet_Change(ByVal Target As Range) If Not Intersect(Target, Target.Worksheet.Range("R1")) Is Nothing Then Dim x As Range, rng As Range Set x = Clé([R1], [G7:P7]): Set rng = Columns("E:F") Application.ScreenUpdating = False If x Is Nothing Then MsgBox "مادة" & " " & [R1] & " : " & " غير موجودة ", vbExclamation: Exit Sub Columns("C:P").EntireColumn.Hidden = True x.EntireColumn.Hidden = False: rng.EntireColumn.Hidden = False ActiveWindow.ScrollColumn = 1 End If End Sub Function Clé(a, b As Range) As Range Dim i& On Error Resume Next i = WorksheetFunction.Match(a, b, 0) If i Then Set Clé = b(i) End Function اظهار الاعمدة Sub Show_all_columns() Sheets("Sheet1").Columns("C:P").EntireColumn.Hidden = False End Sub بطريقة اخرى Sub Hide_columns() Dim Clé As Variant, desWS As Worksheet, rng As Range Set desWS = ThisWorkbook.Sheets("Sheet1"): Clé = [R1].Value If Clé > 0 Then With desWS Set rng = .Rows(7).Find(Clé, LookIn:=xlValues, lookat:=xlWhole) If Not rng Is Nothing Then Application.ScreenUpdating = False .Columns("C:P").EntireColumn.Hidden = True rng.EntireColumn.Hidden = False .Columns("E:F").EntireColumn.Hidden = False Else MsgBox "مادة" & " " & Clé & " : " & " غير موجودة ", vbExclamation: Exit Sub End If End With End If ActiveWindow.ScrollColumn = 1 Application.ScreenUpdating = True End Sub صفحة الرصد V2.xlsm
    3 points
  20. وعليكم السلام ورحمة الله تعالى وبركاته لجلب الصور دفعة واحدة يكفي الوقوف بمؤشر الماوس على اول خلية فارغة على عمود الصور وتشغيل الكود التالي مع تحديد الصور المرغوب اظافتها Sub InsertMultiplePictures() 'اظافة الصور' Set WS = Sheets("ادخال البيانات") Dim Pictures() As Variant Dim j As String, Rng As Range, Cpt As Shape On Error Resume Next Pictures = Application.GetOpenFilename(j, MultiSelect:=True) a = Application.ActiveCell.Column If IsArray(Pictures) Then Col = Application.ActiveCell.Row For lLoop = LBound(Pictures) To UBound(Pictures) Set Rng = Cells(Col, a) Set Cpt = WS.Shapes.AddPicture(Pictures(lLoop), msoFalse, msoCTrue, Rng.Left, Rng.Top, Rng.Width, Rng.Height) Col = Col + 1 Next End If End Sub لافراغ عمود الصور Sub DeleteImage() Dim pic As Picture Set f = Sheets("ادخال البيانات") For Each pic In WS.Pictures If Not Application.Intersect(pic.TopLeftCell, f.Range("G6:G200")) Is Nothing Then pic.Delete End If Next pic End Sub الجدول 1 =INDEX('ادخال البيانات'!$B$6:$G$2000;MATCH('طبع البيانات'!$C$10;'ادخال البيانات'!$B$6:$B$2000;0);6) =MyPicture الجدول 2 =INDEX('ادخال البيانات'!$B$6:$G$2000;MATCH('طبع البيانات'!$C$36;'ادخال البيانات'!$B$6:$B$2000;0);6) =MyPicture2 واخيرا ربط الصور بالنطاق الجمعيه الخيريه 2.xlsb
    3 points
  21. وعليكم السلام ورحمة الله تعالى وبركاته Private Sub TextBox1_Change() Dim a As Variant, b As Variant, Clé$, Rng As Range, i&, j&, k&, m& Dim WS As Worksheet: Set WS = Worksheets("donnes") Dim desWS As Worksheet: Set desWS = Worksheets("search") Clé = "*" & desWS.[B3].Value & "*" Set Rng = desWS.Range("A6:G" & Rows.Count) a = WS.Range("D5", WS.Range("J" & Rows.Count).End(3)).Value If Me.TextBox1 = "" Then Rng.ClearContents Else Application.ScreenUpdating = False With desWS On Error Resume Next .AutoFilterMode = False ReDim b(1 To UBound(a, 1), 1 To UBound(a, 2)) For i = 1 To UBound(a, 1) For j = 1 To UBound(a, 2) 'Filter by Uppercase and lowercase letters If LCase(a(i, j)) Like Clé Or UCase(a(i, j)) Like Clé Then k = k + 1 For m = 1 To UBound(a, 2) b(k, m) = a(i, m) Next Exit For End If Next Next Rng.ClearContents: Range("A6").Resize(k, UBound(b, 2)).Value = b Range("d6:d" & Rows.Count).NumberFormat = "dd-mm-yyyy" End With End If Application.ScreenUpdating = True End Sub بحث VBA V2.xlsm
    3 points
  22. شكرا لك استاذ حسان على الشرح الوافي الكافي و هي فكرتك الأولى ولعلك نسيت اضافة الجدول المحلي ضمن واجهة المستخدم لأن كتابة المقارنة بهذه الطريقة ستعمل لمرة واحدة فقط : 'يتأكد هل فيه نسخة مختلفة If Me.VerNo <> "001" Then ' =====> في كل مرة تقوم بتحدسث النسخة يجب تعديل الاصدار هنا وفي حقل الجدول xVer MsgBox "يوجد اصدار أحدث", 48 + 524288, "تحديث النسخة" واذا سمحت لي باضافة صغيرة : الجدول xver هذا على قاعدة البيانات في السيرفر وهو من سيحمل الرقم الجديد و يوجد جدول (محلي) على واجهة المستخدم يحمل الرقم القديم عند فتح واجهة المستخدم يقارن بين الرقمين في الجدولين .. فإن اختلفا يتم تشغيل التحديث ...... ويتم ايضا تحديث الجدول المحلي بالرقم الجديد /// وبما ان النسخة جديدة يكون المطور هو من وضع الرقم الجديد في الجدول المحلي فلا حاجة للتحديث . ليصبح كود المقارنة بما يشبه هذا : If VerNo1 <> VerNo2 Then
    3 points
  23. مشاركة مع الاخ @Foksh Option Compare Database Option Explicit Private Sub Command0_Click() ExecuteIfChromeOpen End Sub Function IsChromeRunning() As Boolean Dim strCommand As String Dim strOutput As String Dim objWShell As Object Set objWShell = CreateObject("WScript.Shell") strCommand = "tasklist /FI ""IMAGENAME eq chrome.exe""" strOutput = objWShell.Exec(strCommand).StdOut.ReadAll If InStr(strOutput, "chrome.exe") > 0 Then IsChromeRunning = True Else IsChromeRunning = False End If Set objWShell = Nothing End Function Sub ExecuteIfChromeOpen() If IsChromeRunning() Then MsgBox " المتصفح كروم قيد التشغيل. سيتم تنفيذ الأمر", vbInformation, "تأكيد" DoCmd.OpenForm "البيانات" Else MsgBox "يجب فتح المتصفح .", vbExclamation, "المتصفح مغلق" End If End Sub واليك المرفق بالتوفيق Database313.accdb
    3 points
  24. السلام عليكم ورحمة الله وبركاته الملف المرفق من إعدادي بفضل الله ثم بفضل ما تعلمته هنا في المنتدى الزاخر قمت بإعداده لأحد الجمعيات الخيرية العام الماضي وكنت متردد في رفعه للمنتدى نظرا لتوضع العمل مقارنة بأعمال العمالة في المنتدى لكن قررت هذا العام الرفع للاستفادة الملف للتجربة و التقيم ونأمل من الأساتذة الكبار إضافة ملاحظاتهم وإذا كان هناك تعديل أو تحويل المعادلات لأكودا نأمل ألا يبخلو علينا بالتطوير كلمة سر 11 - كلمة سر محرر الأكواد Officena نسأل الله أن يكون في ميزان حسناتنا جميعا ملف رمضان.xls
    3 points
  25. لم يكن خطا برمجي كل ما هنالك بعض السجلات مكررة للرقم
    3 points
  26. تفضل اليك الحلول التالية 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
    3 points
  27. اخي @Ahmed_J ردك هذا هو ما اوقف تعديلاتي لاني عجزت تركيبها في رأسي وايضا رأس الحاسب ... هههههه
    3 points
  28. عليكم السلام ورحمة الله وبركاته "(" & [class_fsl] & "/" & [Class] & ")"
    3 points
  29. وعليكم السلام ورحمة الله وبركاته =IF(AND(I2<>"",K2<>"تم التجديد",(I2-NOW())<100),IF(I2>NOW(),"باقي "&(ROUND((I2-NOW())+1,0))&"","منتهي قبل "&(-ROUND((I2-NOW())+1,0))&""),"")
    3 points
  30. Stop prompt to save a file when printing - Windows This typically occurs when the Print to file option is checked in the print dialog box prior to printing from an application. To adjust this setting: 1. Click File → Print. The steps for printing may vary depending on the application you're using. 2. Uncheck Print to file. 3. Click Print or OK, depending on your application. Your document should now print properly.
    3 points
  31. يعني تريد الرقم الذي يحمله الـــ id اذا فهمي صحيح اكتب السطر التالي في حدث قبل التحديث للحقل الأخير msgbox me.id
    3 points
  32. تفضل اخى جرب الملف قكت بتعديل كود MajStkProv وكود xx() لتاكيد الحصول على الرصيد الصحيح وتم اضافة هذا الكود الى كود التحويل او الحفظ Dim rng As Range Dim cll As Range Dim cll2 As Range Dim lastRow As Long lastRow = ThisWorkbook.Sheets("Stock").Cells(Rows.Count, "A").End(xlUp).Row Set rng = ThisWorkbook.Sheets("Stock").Range("A4:A" & lastRow) For Each cll In rng If cll.Value = Me.CB_Pièce.Text And cll.Offset(0, 11).Value = Me.ComboBox1.Value Then cll.Offset(0, 3).Value = Val(Me.stocktr.Value) - Val(Me.Quantitetr.Value) Exit For End If Next cll For Each cll2 In rng If cll2.Value = Me.CB_Pièce.Text And cll2.Offset(0, 11).Value = Me.ComboBox2.Value Then cll2.Offset(0, 3).Value = Val(Me.TextBox_Stock_Initial.Value) + Val(Me.Quantitetr.Value) Exit For End If Next cll2 تقبل تحياتى نقل المخزون بين المخازن.xlsm
    3 points
  33. تفضل استاذ @canary2522 محاولتي حسب مافهمت . الشرح والمرفق DDT502.rar
    3 points
  34. السلام عليكم و رحمة الله ضع الكودين الآتيين فى حدث الفورم Private Sub CommandButton1_Click() Dim ws As Worksheet, Knd As String Dim x As Integer, Trgt As Range Set ws = Sheets("ورقة1") If Me.ComboBox1.Value = "" Or Me.TextBox1.Value = "" Then MsgBox "يرجى استكمال البيانات" Exit Sub End If Knd = Me.ComboBox1.Value x = WorksheetFunction.Match(Knd, ws.Range("A1:F1"), 0) Set Trgt = ws.Cells(2, x) Trgt.Value = Trgt.Value + Me.TextBox1.Value Me.ComboBox1.Value = "" Me.TextBox1.Value = "" End Sub Private Sub UserForm_Initialize() For Each c In Range("A1:F1") Me.ComboBox1.AddItem c Next End Sub
    3 points
  35. عملت لك استعلام واحد يستخرج جميع بنودك المطلوبة ... واستعلام آخر بالرصيد تعريف الاستعلام : بالرغم من كونه شقيق الجدول واكثر مرونة منه الا انه نسخة طبق الأصل من نماذج العرض ومن التقارير الفرق بينها في الغالب دوما ان البيانات في التقارير تكون مرتبة على هيئة ورق مثلا A4 ومنسقة وتشتمل على الشعارات والترويسة والتذييل ، والا البيانات هي البيانات والنتائج هي النتائج ونوظف النماذج لخدمة الاستعلامات في الضبط فيما يخص المعايير ، لذا حينما تفتح الاستعلام في المثال سوف يطالبك بكتابة المعايير ( ولن تظهر اذا تم ربط المعيار بالنموذج ) نأتي للاستعلام الشامل الذي تم عمله : المعايير : ( بين تاريخين / بين رقمين للحساب / بين رقمين للصنف ) جرب 1- لا تكتب شيئا عند المطالبة بادخال المعايير .. وانما انقر على موافق فقط .. سوف تظهر جميع البيانات الموجودة في الجدول ، وينطبق هذا ايضا على استعلام الأرصدة 2- جرب ادخل التواريخ فقط او التواريخ والحساب من/الى او ضع رقما واحدا في : من/الى ... وطبق ايضا على الاصناف الذي اريد ان اوصله انه يمكن التصفية بحسابات محددة واصناف محددة وتواريخ محددة في نهاية البرنامج يمكننا جعل هذا الاستعلام او جزء منه مصدرا لتقريرنا جرب وتفحص وزد في البيانات وراقب ووافنا بالنتيجة ملحوظة : ارقام الحسابات والاصناف تبدأ من 101 .. وهذا الرقم سوف يتكفل النموذج بادخاله مستقبلا tables3.rar
    3 points
  36. وهذا تعديل بسيط في الكود حتى لا يقع يوم التاخر في ضمن اطار اجازة الموظف ................ Private Sub Form_BeforeUpdate(Cancel As Integer) Dim rst As dao.Recordset Set rst = CurrentDb.OpenRecordset("SELECT hol.lateday, hol.ck, hol.Rea, hol.[no], hol.ck, hol.Rea, hol.absdate, hol.start_date, hol.end_date " & _ " FROM hol " & _ " WHERE (((hol.[no])=" & [Forms]![late-enter]![no] & ")) " & _ "ORDER BY hol.lateday;") rst.MoveFirst Do Until rst.EOF If rst!lateday = Me![نص15] Then MsgBox " تاريخ التاخر هذا مسجل سابقا لهذا الموظف ", , " تنبيه" Me.Undo DoCmd.CancelEvent Exit Do ElseIf rst!absdate = Me![نص15] Then MsgBox " الموظف غائب اليوم ", , " تنبيه" Me.Undo DoCmd.CancelEvent Exit Do ElseIf Me![نص15] >= rst!start_date And Me![نص15] <= rst!end_date Then MsgBox " التاريخ موجود ضمن فترة إجازة الموظف ", , " تنبيه" Me.Undo DoCmd.CancelEvent Exit Do End If rst.MoveNext Loop rst.Close End Sub
    3 points
  37. استبدل الكود لديك بهذا .......................... Private Sub Form_BeforeUpdate(Cancel As Integer) Dim rst As dao.Recordset Set rst = CurrentDb.OpenRecordset("SELECT hol.lateday, hol.ck, hol.Rea, hol.[no], hol.ck, hol.Rea, hol.absdate, hol.start_date, hol.end_date " & _ " FROM hol " & _ " WHERE (((hol.[no])=" & [Forms]![late-enter]![no] & ")) " & _ "ORDER BY hol.lateday;") rst.MoveFirst Do Until rst.EOF If rst!lateday = Me![نص15] Then MsgBox " تاريخ التأخر مكرر ", , " تنبيه" Me.Undo DoCmd.CancelEvent Exit Do ElseIf rst!absdate = Me![نص15] Then MsgBox " الموظف غائب اليوم ", , " تنبيه" Me.Undo DoCmd.CancelEvent Exit Do End If rst.MoveNext Loop rst.Close End Sub
    3 points
  38. السلام عليكم كان عليك استخدام خاصية البحث بالمنتدى قبل رفع مشاركتك فالمنتدى كنوز -تفضل على الرغم انك لم تقم برفع ملف اكسيل موضح به المطلوب بكل دقة https://www.officena.net/ib/topic/22735-طباعة-الشهادات-المدرسية/ وهذا أيضاً برنامج صانع الشهادات المدرسية https://www.jo-teachers.com/forum/t9644
    3 points
  39. أخي الكريم @عبدالقدوس48 هل تتوقع ان من يجيب هو من يضع الامثلة والمرفق ..... ام السائل هو من يزودنا بالمرفق للتطبيق عليه بعد دراسة طريقته في البرنامج ووضع الحل المناسب لمرفقه .... بارك الله فيك
    3 points
  40. ايضا انا استعجلت في الرد فهو قد عالج مسألة التكرار بنفس الطريقة التي بينتها .. ولكني لم انتبه لتحديثه
    3 points
  41. معلمنا الفاضل هذا من حسن حظي بلا شك لا شك أن ألأستاذ @Barna أنتج عمل جميل وذكي ، إلا أن فكرتي كانت بتوسيع المجال ليس إلا
    3 points
  42. جزيل الشكر لكم اخوتي حل آخر باستخدام بور كويري المصنف1.xlsx
    3 points
  43. من الافضل جعل قيمة القائمة المنسدلة دور ثان فقط بدون له او لها واستخدام الكود التالي Sub Filter_and_copy_with_condition() Dim d, j Dim Search As Range, clé As String, IRow As Long Dim WS As Worksheet: Set WS = Worksheets("control4") Dim F As Worksheet: Set F = Worksheets("saad") d = 9: j = 16: clé = "*" & F.[k1] IRow = WS.Range("U:U").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row With Application .Calculation = xlManual .ScreenUpdating = False If Len([k1].Value) = 0 Then: Exit Sub Set Search = WS.Range("U16:U" & IRow).Find(clé, LookIn:=xlValues, lookat:=xlWhole) If Search Is Nothing Then MsgBox clé & " " & "غير موجود", vbExclamation, "Admin": Exit Sub F.Range("C10:O" & Rows.Count).ClearContents Do Until IsEmpty(WS.Range("U" & j)) If WS.Range("U" & j) Like clé Then d = d + 1 F.Cells(d, 3).Value = WS.Cells(j, 3).Value F.Cells(d, 5).Value = WS.Cells(j, 5).Value F.Cells(d, 6).Value = WS.Cells(j, 6).Value F.Cells(d, 8).Value = WS.Cells(j, 10).Value F.Cells(d, 10).Value = WS.Cells(j, 12).Value F.Cells(d, 11).Value = WS.Cells(j, 13).Value F.Cells(d, 12).Value = WS.Cells(j, 16).Value F.Cells(d, 13).Value = WS.Cells(j, 17).Value F.Cells(d, 14).Value = WS.Cells(j, 18).Value F.Cells(d, 15).Value = WS.Cells(j, 21).Value End If j = j + 1 Loop .Calculation = xlAutomatic .ScreenUpdating = True End With End Sub مصطفي V3.xlsb
    3 points
  44. تفضل ووافينا بالنتيجة Sub Filter_and_copy_with_condition() Dim Rng As Range, Search As Range Dim Col As Variant, a As Variant, MyRng As Variant, clé As Variant Dim i As Long, F As Long, Cpt As Long, Lastrow As Long, Irow As Long, ColStar As Long Dim WS As Worksheet: Set WS = Worksheets("control4") Dim desWS As Worksheet: Set desWS = Worksheets("saad") clé = desWS.[k1]: ColStar = 10 'نطاق البيانات Lastrow = WS.Range("U:U").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row Set Rng = WS.Range("C16:U" & Lastrow) Col = Rng.Value2 If Len([k1].Value) = 0 Then: Exit Sub With desWS Set Search = WS.Range("U16:U" & Lastrow).Find(clé, LookIn:=xlValues, lookat:=xlWhole) If Search Is Nothing Then MsgBox clé & " " & "غير موجود", vbExclamation, "Admin": Exit Sub Application.ScreenUpdating = False ' تخزين البيانات القديمة Irow = desWS.Columns("C:AT").Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row For Cpt = ColStar To Irow MyRng = desWS.Range("P10:AT" & Cpt).Value Next ' افراغ البيانات السابقة desWS.Range("C10:O" & Cpt).ClearContents ReDim a(1 To UBound(Col), 1 To UBound(Col, 2)) End With For i = 1 To UBound(Col) ' عند تحقق الشرط If Col(i, 19) = clé Then F = F + 1 a(F, 1) = Col(i, 1): a(F, 3) = Col(i, 3): a(F, 4) = Col(i, 4) a(F, 6) = Col(i, 8): a(F, 8) = Col(i, 10): a(F, 9) = Col(i, 11) a(F, 10) = Col(i, 14): a(F, 11) = Col(i, 15): a(F, 12) = Col(i, 16): a(F, 13) = Col(i, 19) End If Next i [C10].Resize(F, UBound(a, 2)).Value2 = a For Cpt = ColStar To Irow desWS.Range("P10:AT" & Cpt).Value = MyRng Next Application.ScreenUpdating = True End Sub وفي حدث ورقة saad ضع الكود التالي Private Sub Worksheet_Change(ByVal Target As Range) On Error Resume Next If Not Intersect(Target, Range("k1")) Is Nothing Then Call Filter_and_copy_with_condition End If End Sub مصطفي V2.xlsb
    3 points
  45. استخدم المعادلة التالية باعتبار أن الرقم القومي في الخلية B3 =DATEDIF(DATE(IF(LEFT(B3;1)*1=3;20;19)&MID(B3;2;2);MID(B3;4;2);MID(B3;6;2));TODAY();"y") حيث يتم تقسيم الرقم القومي إلى شهر وسنة وأيام وبعدها يتم طرحه من اليوم الحالي today واظهار الناتج بالسنة y
    3 points
  46. أستاذ @Ahmed_J ، خليني افهم حبة حبة لأن احياناً استيعابي يكون بطيء حبتين بعد الأكل .. هالحين انت محتاج من تختار من القائمة B يروح يعمل بحث في كل الحقول - حتى لو عددهم 50 - اللي سجلها رقمه يطابق GradeNo في القائمة A . انا عملت الـ GradeNo رقم 8 يساوي كاتب في الحقلين باعتبار وجود أكثر من حقل في الجدول . وعند اختيار رقم 8 من النموذج من A وتختار اي اختيار في B غير كاتب رح تكون النتيجة انه عدم تطابق في البيانات .. ومن تختار كاتب ما رح يظهر رسالة . الحين هذا اللي انا دخت وأنا أشرحه صحيح ولا لا سمح الله غلط . هذا الكود اللي خرجت فيه بالنهاية ، والمرفق أسفله :- Private Sub B_AfterUpdate() Dim db As DAO.Database Dim rs As DAO.Recordset Dim sql As String Dim found As Boolean Dim field As DAO.field found = False Set db = CurrentDb sql = "SELECT * FROM TP2 WHERE GradeNo = " & Me.A Set rs = db.OpenRecordset(sql) If Not rs.EOF Then found = True rs.MoveFirst For Each field In rs.Fields If field.Name <> "GradeNo" And field.Value <> Me.B Then found = False Exit For End If Next field End If rs.Close If found Then MsgBox "بيانات متطابقة", , "" Else 'If Not found Then MsgBox "بيانات غير متطابقة", , "" End If End Sub Test-1.accdb
    3 points
×
×
  • اضف...

Important Information