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

تفضل جرب المرفق ...... nabilemployer_kan2.accdb

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

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

جرب المرفق بدون جداول وتعب دماغ فقط وضعنا مربع اختيار .... nabilemployer_kan.accdb

وعليكم السلام .... ولكن ماهو هذا الجدول المرحل له ,,,, هل هي ترحيل من اجل نسخة احتياطية ,,,, أم ماذا ؟؟؟؟؟ وضح اكثر وبالتفصيل ... حتى يمكن مساعدتك

كلام صحيح .. لان الكود يعتمد على الفترة الزمنية بين كتابة الرقم الاول والثاني... ولا اعتقد ان هناك باركود عبارة عن رقم واحد .. .... لكن جاري البحث عن كود يلبي طلبك

جرب هذا الكود لإجراء الترحيل Sub migration() Application.ScreenUpdating = 0 lr1 = Sheets("migration").Cells(Rows.Count, 2).End(xlUp).Row lr2 = Sheets("ALL DATA").Cells(Rows.Count, 2).End(xlUp).Row Sheets("migration").Range("b4:n" & lr1).Copy Sheets("ALL DATA").Select Sheets("ALL DATA").Range("B" & lr2 + 1).PasteSpecial Paste:=xlPasteValues Application.CutCopyMode = 0 Sheets("ALL DATA").Range("B4").Select Sheets("migration").Select For n = 4 To lr1 Dim cl As Range, inrange As Boolean For Each cl In Range(Cells(n, 2)) If cl.Value = Cells(n, 2).Offset(0, 4).Value Then inrange = True Next If Not inrange Then Range(Cells(n, 2)).Cells(Range(Cells(n, 2)).Cells.Count).Offset(1) = Cells(n, 2).Offset(0, 4).Value Next n Range("b4:n52").ClearContents Range("B4").Select Application.ScreenUpdating = 1 MsgBox "Done" End Sub بالتوفيق

ما شاء الله تبارك الله ..... معلم يا استاذ @kha9009lid >>>>

مشاركة مع ملف استاذي Barna اصبح لدينا تقرير واحد بدل تقريرين ..... test_bar.accdb

مشكور استاذى أ / محمد صالح اتنفذ المسار بس فى مشكلتين قابلتنى مع الكود الان عن الضغط على استيراد حتى دون تحديد المسار لملف الاكسيل يتم استيراد البيانات وعند التصدير كل مرة تخرج لى رسالة حدث مشكلة فى التصدير كمان الان لا يوجد دور لمسار الملف الذى باعلى الزرين استيراد وتصدير اسم الملف الاكسيل اريده باسم قاعدة البيانات الان اسمه tbl_Items.xlsx بارك الله فيك اخى الكريم DATA10041.mdb

بارك الله فيك استاذ محمد للاسف لم يعمل Private Sub estrad_Click() On Error Resume Next Dim ImpEX As String Dim strSQL As String ' ÍÐÝ ãÍÊæíÇÊ ÇáÌÏæá strSQL = "DELETE tbl1.* FROM tbl_Items;" DoCmd.SetWarnings False DoCmd.RunSQL strSQL DoCmd.SetWarnings True ' ÇÓÊíÑÇÏ ÌÏæá ÇáÅßÓá Åáì ÌÏæá ÇáÃßÓÓ ÇáãØáæÈ If Me.FilePath = "" Then MsgBox "íÌÈ ÊÍÏíÏ ãÓÇÑ ÇáãáÝ ÇæáÇð", vbCritical + vbMsgBoxRight, "ÊäÈíå" Call FileDialog_Click Exit Sub End If ImpEX = Me.FilePath.Value ' ImpEX = CurrentProject.Path & "\" & "tbl_Items.XLSX" DoCmd.TransferSpreadsheet acImport, 8, "tbl_Items", ImpEX, True MsgBox "ÃßÓÓ ÇÓÊæÑÏ ÇáÈíÇäÇÊ ÇáãØáæÈÉ ãä ãáÝ ÅßÓá ÈäÌÇÍ" End Sub وعند الضغط على استيراد لم يطلب تحديد مسار الملف الذى سيتم الاستيراد منه شكر وتقدير من القلب

أخي الكريم هل مازلت لم تعرف سبب الخطأ؟؟؟؟

جربت الدخول باسم المستخدم a وكلمة المرور 1 فظهر الخطأ فعلا عند هذا السطر Sheets("Daily Report").Activate ولا يوجد شيت بهذا الاسم وهذا سبب الخطأ والشيت في السطر التالي أيضا غير موجود ضمن مجموعة الشيتات

استاذنا العزيز جزيل الشكر والتقدير لمجهودتك ادم الله عليكم الصحة والعافيه وكلمة السر 1 تظهر المشكلة حيث ان المستخدمين لهم صلاحية مدخل بيانات ويشاهد فقط ومدير حيث ان الرساله تظهر عند الدخول بالمستخدم الموضح الذ يشاهد فقط A اوضح بانه عند الدخول باسم المستخدم Actioin Tracking Register All - Copy (1).xlsm

كود حفظ الصفحة النشطة PDF

لا يوجد مشكلة يمكنك استعمال هذه المعادلة في E4 =IF(ISERR(FIND("بالساعة",A4)),C4/D4,D4/C4)

لا اختلاف

اشكرك اولا على تجاوبك أ/ محمد صالح وعلى مجهودك في عمل الكود ان شاء الله اجرب الكود وارجع لك خبر .ربنا يفرج عنك كل هم وينفس عنك كل كرب ويجزيك عنا كل خير . تحياتي وتقديري لك ولبقية الاساتذة الافاضل 🌹

حتى يعمل ينبغي وضع قبل end if Call FileDialog_Click exit sub للخروج من الاجراء وفتح مستعرض الملفات وبالنسبة لموضوع اسم الملف فالذي يحدده المستعرض ربما لم يصلني ما تريد بدقة

بالنسبة للسؤال الأول أعتقد أن المشكلة في طريقة ربط النموذج بالاستعلام حيث يمكنك إنشاء نموذج جدولي،من خلال المعالج للاستعلام وتعيد تنسيقه كما تشاء ثم تضيف قائمة باسماء الموظفين للنموذج ثم تكتب في الاستعلام مسار عنصر القائمة وفي حدث بعد التحديث للقائمة نستعمل me.requery بالنسبة للسؤال الثاني لي افتراح يمكنك اضافة حقل عدد ايام العمل وياخذ الموظف نسبة هذه الايام على عدد ايام الشهر او على 30 بصورة ثابتة فمثلا من عمل من منتصف الشهر يكون راتبه الراتب في 15 على 30 وبهذا يحصل على نصف الراتب وهكذا

يمكنك تجربة هذا المرفق بإخراج آخر وتكبير حجم شريط التقدم وكتابة النسبة في المنتصف في تسمية واحدة شفافة بالتوفيق Classeur1111.rar

تفضل أخي الكريم يمكنك استخدام دالة معرفة udf لجلب معيار او معيارين للفلتر في الخلية وتكون فارغة في حالة عدم تشغيل الفلتر Function AutoFilter_Criteria(Rng As Range) As String Dim str1 As String, str2 As String Application.Volatile With Rng.Parent.AutoFilter With .Filters(Rng.Column - .Range.Column + 1) If Not .On Then Exit Function str1 = CStr(.Criteria1) If .Operator = xlAnd Then str2 = " AND " & CStr(.Criteria2) ElseIf .Operator = xlOr Then str2 = " OR " & CStr(.Criteria2) End If End With End With AutoFilter_Criteria = Replace(UCase(Rng) & ": " & str1 & str2, "=", "") End Function ولاستدعائها =AutoFilter_Criteria(C7) بالتوفيق

ألف شكر أستاذ / محمد ... الله يجزاك خير .. ماقصرت يا غالي

دمت بخير

يا اخي كل هذا معروف الذي استوقفني في طلبك كلمة بدون تغيير لغة النظام وقولك بعد ذلك أن هذا الكود لا يغير لغة النظام بالتوفيق

الكمبيوتر لا يفرق بين لوحة المفاتيح والقارئ .. لذا كل الإدخالات لن تتم حتى التي عن طريق القارئ.

لا يظهر عندي أي خطأ وخصوصا انه لا يوجد كود في حدث عند الفتح

تم حل المشكلة قمت بتعديل الكود ونجح الامر وضعت الحل هنا حتى يستفاد غيري Private Sub R3_Click() If MsgBox("åá ÊÑíÏ ÇÌÑÇÁ äÓÎÉ ÇÍÊíÇØíÉ ãä ÇáÈÑäÇãÌ¿", _ vbQuestion + vbYesNo, _ "äÓÎÉ ÇÍÊíÇØíÉ") = vbYes Then On Error Resume Next Dim fileName As String fileName = GetDesktop & "\" & "Backup" & "" ' fileName = GetDesktop Dim OldFile As String, DBwithEXT, DBwithoutEXT, NewFile As String, CopyMyDB Dim fs, cf, strFolder ' strFolder = CurrentProject.Path & "\Backup" strFolder = fileName Set fs = CreateObject("Scripting.FileSystemObject") If fs.FolderExists(strFolder) = False Then Set cf = fs.CreateFolder(strFolder) End If ' OldFile = CurrentDb.Name OldFile = CurrentProject.Path & "\DataBe\Data.DB" ' مسار حفظ النسخة ' StrNew = CurrentProject.Path & "\Backup" StrNew = fileName DBwithEXT = Dir(OldFile) DBwithoutEXT = Left(DBwithEXT, Len(DBwithEXT) - 6) If [BKUP] = True Then NewFile = StrNew & "\" & DBwithoutEXT & "-" & Format(Date, "yyyy-mm-dd") & "-" & Format(Now(), "Hh-Nn-Ss-AMPM") & Right(DBwithEXT, 6) CopyMyDB = "cmd.exe /C copy " & """" & OldFile & """" & " " & """" & NewFile & """" Shell CopyMyDB, 0 Exit Sub End If End If End Sub 'هذه الدالة تستخرج مسار سطح المكتب لديك Function GetDesktop() As String Dim oWSHShell As Object Set oWSHShell = CreateObject("WScript.Shell") GetDesktop = oWSHShell.SpecialFolders("Desktop") Set oWSHShell = Nothing End Function الكود يقوم بعمل نسخة في سطح المكتب داخل مجلد Backup توجد مشكلة بسيطه وهي: اذا كان عدد حروف اسم القاعدة الخالفية اكبر من سته احرف فانه يقتطع مابعد 6 ويضع الفرمات التاريخ والوقت ويكمل بقية الاحرف بعد ذلك فياريت اجد حل يضع اسم القاعدة كما هو .. وبعد ذلك فرمات التاريخ والوقت وبعد ذلك الامتداد الكود المسؤل عن هذا التالي: NewFile = StrNew & "\" & DBwithoutEXT & "-" & Format(Date, "yyyy-mm-dd") & "-" & Format(Now(), "Hh-Nn-Ss-AMPM") & Right(DBwithEXT, 6) شاكرا لكل من ساهم و رد على الموضوع

حسب علمي قارىء الباركود لا يقرأ اقل من 3 خانات بمعنى انه لا يقرأ الباركود المكون من رقم او رقمين وينطبق هذا على الحروف

تظهر لديك في ال Font

ربنا يكرمك استاذى الحبيب محمد أبوعبدالله حفظك الله ورعاك وبارك فيك بارك الله فيك اخى الكريم استاذ أ / محمد صالح زادك الله من فضله استاذى اردت عمل اضافة للكود فى حالة ان المسار فارغ وضغطت استورد يخرج رسالة يجب تحديد مسار الملف اولا ووضعت الشرط والرسالة فى اول الكود بس للاسف لم يعمل كمان اريد تغير اسم الملف الاكسيل بدل tbl_Items.XLSX الى اسم قاعدة البيانات ربنا يكرمك استاذى الغالى بارك الله فيك On Error Resume Next Dim ImpEX As String Dim strSQL As String ' ÍÐÝ ãÍÊæíÇÊ ÇáÌÏæá strSQL = "DELETE tbl1.* FROM tbl_Items;" DoCmd.SetWarnings False DoCmd.RunSQL strSQL DoCmd.SetWarnings True ' If FilePath = "" Then MsgBox " يجب تحديد مسار الملف اولا", vbCritical + vbMsgBoxRight, "تنبيه" End If ImpEX = Me.FilePath.Value ' ImpEX = CurrentProject.Path & "\" & "tbl_Items.XLSX" DoCmd.TransferSpreadsheet acImport, 8, "tbl_Items", ImpEX, True MsgBox "اكسس استورد البيانات المطلوبة من ملف اكسيل بنجاح"

بعد إذن أخي محمد ابو عبد الله وإذا كنت تريد التصدير لنفس الملف يمكنك استبدال هذا السطر في كود التصدير ExpEX = CurrentProject.Path & "\" & "tbl_Items.XLSX" بالتالي ExpEX = Me.FilePath.Value طبعا بشرط أن يتم تحديد الملف بزر استعراض اولا والا يكون اسم الملف فارغا بالتوفيق

السلام عليكم عند الاستيراد اضفط زر استعراض اولاً ثم خدد الملف واضغط زر استيراد وعند التصدير استخدم الكود التالي On Error GoTo err: DoCmd.OutputTo acOutputTable, "tbl_Items", acFormatXLSX, , False MsgBox "أكسس صدر البيانات المطلوبة إلى ملف إكسل بنجاح" err: MsgBox "مشكلة بتصدير الملف" DATA10041.mdb تحياتي

2الجبلاوى الأمر فى غاية البساطة لأنك لم تقم بالضغط على ctrl+Shift+Enter بعد كتابة وصياغة المعادلة فهذه ليست معادلة عادية ولكنها معادلة مصفوفة

تفضل الطريقتين : الاولى ... تختار من مربع الاختيار الموظفين ثم تطبع الثانية ... تحدد التسلسل المطلوب من مثلا 1 الى 5 ثم تطبع بارك الله فيك ... test_bar.accdb

ليس هذا رأيهم ....... حاول ... وحاول ..... بطرق اخرى تلبي طلبك .... هي هذه البرمجة ..... اسلك طريق اخر ....... !!!!!! هذا رأيهم اعتقد ذلك ....

طيب ممكن مرفق كمثال للتطبيق عليه !!!!

الكود السابق الحقيقة يعيد المؤشر مرة اخرى لمربع النص المسمى a فلا يترك فرصة لعمل مفتاح الاعلى والاسفل ....

تحتاج مراجعة الاكواد في النموذج مثلا هذا الكود عند الخروج يتعارض مع ما تريده ..... Me.sn.SetFocus DoCmd.GoToRecord , , acNewRec Me.a.SetFocus

نسبة نجاح تحويل ملفات pdf إلى اللغة العربية لا تتجاوز 60 بالمائة ويمكنك استعمال التدقيق الاملائي مع التصحيح اليدوي وربنا يعينك

إذا كنت تقصد شريط الوصول السريع QAT فهذا يمكن تخصيصه لمصنف معين أما الشريط كله ribbon فيمكن إضافة تبويبات جديدة او إخفاء تبويبات كاملة ولكن على مستوى التطبيق وليس على مستوى المصنف بالتوفيق

اضف مربع اختيار .... ويتم التصفية للطباعة فقط المختار من خلال الشيك بوكس

السلام عليكم تم تصويب الكود حسب الطلب... بن علية حاجي بيان ناجح 6.xlsm

جرب هذا الماكرو Option Explicit Private Fltr_range As Range, I_range As Range Private EHsaa As Worksheet, Tasj As Worksheet Private lr_EHsaa%, lr_Tasj, m% '=============================== Sub my_filter() Set EHsaa = Sheets("احصاء الغيابات") Set Tasj = Sheets("تسجيل الغيابات") lr_EHsaa = EHsaa.Cells(Rows.Count, 2).End(3).Row lr_Tasj = Tasj.Cells(Rows.Count, 2).End(3).Row Set Fltr_range = Tasj.Range("B6:E" & lr_Tasj) Set I_range = EHsaa.Range("T1:T6") lr_EHsaa = IIf(lr_EHsaa = 3, 4, lr_EHsaa + 1) Dim i% For i = 1 To I_range.Rows.Count Call Filter_FOR_Me(Fltr_range, 3, EHsaa.Range("T" & i)) Next EHsaa.Range("b3").Select Application.CutCopyMode = False Fltr_range.AutoFilter End Sub '============================================= Sub Filter_FOR_Me(rg As Range, n, St) rg.AutoFilter , field:=n, Criteria1:=St rg.Offset(1).Resize(rg.Rows.Count - 1).Copy EHsaa.Range("B" & lr_EHsaa).PasteSpecial xlValues m = EHsaa.Cells(Rows.Count, 2).End(3).Row + 1 lr_EHsaa = m + 1 End Sub الملف مرفق Abscence.xlsm

(بسم الله الرحمن الرحيم السلام عليكم ورحمة الله وبركاته هذا آخر ما تم تعديله في البرنامج مع العلم بأن البرنامج مفتوح لمن أراد التعديل أو المساعدة أولا مميزات البرنامج - يسمح بإدخال البيانات من المعلمين بصورة جزئية جدا تبدأمن درجات الشفوي والتحريري والسلوك وهكذا في كل الشهور في شاشة واحدة وذلك بالطبع في كل المواد الدراسية في المرحلة الاعدادية -- مع سهولة البحث عن الطلاب لسرعة وضع درجات معينة لطالب معين على مدار الشهر -وبعد الانتهاء من وضع درجات جميع المواد في شهر معين تستطيع إخراج كشف شامل لدرجات الطلاب في كل المواد ومجموعها ونسبة النجاح -وفي أثناء ذلك لمن أراد من المعلمين معرفة درجات طلابه في مادته فقط مجموعة ومرتبة من أعلى الطلاب درجات إلى أقل الطلاب يمكنه عمل ذلك في كل الشهور مع عرض هذه الاستعلامات في وضع غير قتبل للتعديل أو التغيير -من البداية تدخل أسماء الطلاب مرة واحدة وإن كانت غير مرتبة فالبرنامج يقوم بترتيبها أبجديا ويلزمك فقط إعادة ترتيب رقم المسلسل ويسمح بتغيير هذا الرقم ولا تحتاج لتكرارها في شاشة المواد فستجدها مكتوبة وأيضا غير قابلة للتعديل فقط أدخل درجات الطالب الذي تريده - يعد الانتهاء من رصد جميع درجات المواد في جميع الشهور والفصلين الدراسيين يمكنك عرض نتيجة أجمالية لكل الطلاب أو الناجحين في الدور الأول فقط أو من لهم دور ثان وأيضا يمكنك من طباعة الشهادات المدرسية بضغطة زر واحدة بدلا من كتابة جميع الطلاب في ورق الشهادات وكل درجات هذا الطالب وذلك في الفصل الدراسي الأول وفي النتيجة النهائية وفي الناجحين في الدور الثاني - بعد معرفة من لهم دور ثان يمكنك بعد امتحان الدور الثني إدخال درجات الطلاب في نموذج خاص يذلك ويقوم البرنامج بحساب الناجحين في الدور الثاني وإلحاقهم بالناجحين في الدور الأول وعرضهم جميعا في كشف جميع الناجحين ويعرض الراسبين في الدور الثاني وهم باقون للإعادة ومازال هناك الكثير من الأعمال المطلوبة ومنها = عدم الحاجة لكتابة مسلسل الأرقام بعد كتابة الأسماء وغلق النموذج وفتحة لنجدها مرتبة مع ترتيب الأسماء = عمل كلمة مرور لكل نموذج إدخال بيانات الخاص بكل مادة مع امكانية تشغيل كلمة المرور وتغييرها وإلغائها وهذا الكلمة تسمح بالتعديل فقط وبدونها يتم عرض النماذج فقط =هذا البرنامج لصف دراسي واحد وسيتم وضع نفس عدد الجداول والاستعلامات والنماذج والتقارير للصف الثاني بعد الانتهاء من النتيجة وعرض الناجحين جميعا سيتم ترحيلهم إلى الصف الأعلى بضغطة زر ومسح جميع درجات المواد استعدادا للعام الدراسي الجديد =فالله الموفق ومن يستطيع تقديم أحد هذه الخدمات فلا يبخل والسلام عليكم ورحمة الله وبركاته ________________________.rar

وياريت لو توضح كيفية منع التكرار

أخي العزيز نتعاون من أجل الوصول للأفضل وزيادة على ما قام به الزميل العزيز قمت ببعض التعديلات حسب طلباتك مع التيسير في اختيار رقم الموظف من قائمة وليس كتابته مع وجود تقرير وغيرها أتركك مع التعديل ويارب يكون عند حسن ظنك empdb.rar

وجدت هذا البرنامج الجميل الذي يمكنك من ضغط وإصلاح قواعد البيانات الخاصة بك من خلال هذا البرنامج ويفيد هذا البرنامج في حالات إخفاء نافذة الأكسس وأنصح بتحميل نسختين مع تغيير الاسم أو مكانها على الجهاز لتضغط وتصلح كل واحدة منهم الأخرى إلى البرنامج الذي قمت بتعريبه فقط إلى البرنامج إلى البرنامج إلى البرنامج _______________.rar

أخي الكريم وجدت هذا البرنامج في منتدى أجنبي ولكن ينقصه مجهودك فبه معلومات عن الصورة لا توجد هذه الصور في ألبومات ومناسبات فهل نتشارك لنخرج عملا جيدا؟ الملف في المرفقات ___________.rar

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