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

وعليكم السلام محمد.. الملفات الثنائية لها معرفات نصية في أول سطر من الملف! يمكن الاستفادة من هذه الميزة للتعرف على الملف الأصلي حتى لو غُيرت اللاحقة! افتح الملف بواسطة محرر النصوص التقليدي للحصول على معرف الملف ثم استخدم هذا المعرف في فحص القيمة.. في أكسس الشفرة التالية تفي بالغرض إن شاء الله Sub TestData() On Error Resume Next Dim fn, ft fn = CurrentProject.Path & "\testdata\testdata.msi" Open fn For Input Access Read As #1 Line Input #1, ft Close #1 If ft Like "*Standard ACE DB*" Then Name fn As Replace(fn, ".msi", ".accdb") End If End Sub

مشاركة بالفكرة السابقة ..... للتجربة على ملفك ........ kanory.mdb

فكرة بفكرة يمكن تنفيذها وهي : اولا نحتاج تغيير امتداد ملفك الى ملف امتداد ملف اكسس ثانيا نفحص هذا الملف هل هو ملف اكسس صالح فيعطي رسالة بذلك او معطوب فيعطي رسالة ايضا بذلك . . . . افكر في تنفيذها إن اردت .... جاري العمل على ذلك ..............

تفضل ..... المرحله.accdb

ربما هذا يفيدك .... copy.accdb

مساهمة مع الاساتذه الكرام .... جرب المرفق واعلمنا بالنتيجة الارقام.accdb

استخدم هذا الفانك ولاحظ التغيرات وحاول فهم التعديل ...... Function kanory1() On Error Resume Next Dim RSB As DAO.Recordset Dim RSD As DAO.Recordset Dim RSJ As DAO.Recordset Set RSB = CurrentDb.OpenRecordset("tblTempS", 2) Set RSD = CurrentDb.OpenRecordset("tblTempe", 2) Set RSJ = CurrentDb.OpenRecordset("tblTempS", 2) Dim I As Integer ', ClassDay As String, BM RSB.MoveLast RSB.Edit RSB!F24 = "الجهة" RSB.Update RSB.MoveFirst '+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Do Until RSB.EOF see: If RSB!F24 Like "*الجهة*" Then g = RSB!f7 ' ElseIf RSB!F20 Like "*الخدمة الرئيسية*" Then ' t = RSB!f5 ' ElseIf RSB!F20 Like "*الخدمة الفرعية*" Then ' s = RSB!f6 End If RSB.MoveNext If RSB!F24 Like "*الجهة*" Then GoTo se Loop '++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ se: Do Until RSJ.EOF If IsNumeric(RSJ!F25) Then RSD.AddNew RSD!f3 = RSJ!F2 RSD!f4 = RSJ!F25 RSD!f5 = RSJ!F22 RSD!F6 = RSJ!F18 RSD!f7 = RSJ!F16 RSD!F8 = RSJ!f14 RSD!F9 = RSJ!F13 RSD!F10 = RSJ!F10 RSD!f11 = RSJ!F8 RSD!f12 = RSJ!F6 RSD!f1 = g ' RSD!F2 = t ' RSD!f3 = s RSD.Update End If RSJ.MoveNext If RSJ!F24 Like "*الجهة*" Then g = "" t = "" s = "" GoTo see End If Loop DoCmd.OpenTable "tblTempe" DoCmd.Close acForm, "frmdrjat" End Function

تسلم اخي خالد ....

طيب ... بارك الله فيك اخي الكريم جرب المرفق التالي ..... الباحث فى القرآن الكريم للتعديل.rar

اين تبدو الايه ناقصة ..... عندي ظاهرة كاملة الاية .... وضح طلبك

بالحقيقة عندما ارى هكذا روائع ..يبدوا لي اني كالعصفور امام الصقور الحرة (الشاهين You are awesome Dr.

انظر للمثال المرفق..هل هذا المطلوب؟ Q.accdb

لا أعتقد وجود معادلة تقوم بهذا الدور لذلك يمكنك استعمال اكواد vba مع ملاحظة ان اختيار الاسم في شيت A يجب ان يكون من قائمة الاسماء في شيت B لضمان المطابقة تم وضع معادلات للعد وكود لجلب أيام العياب مجمعة بالتوفيق دمج أيام الغياب في خلية واحدة.xlsb

جرب استعمال هذا الكود Sub masTar7eel() Application.ScreenUpdating = 0 Range("B2:B16").Copy Sheets("الشيت").Select lr = Cells(Rows.Count, 1).End(xlUp).Row + 1 Range("A" & lr).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True Application.CutCopyMode = 0 Range("A" & lr).Select Sheets("ادخال بيانات").Select Range("B2:B16").ClearContents Range("B2").Select Application.ScreenUpdating = 1 MsgBox "Done by mr-mas.com" End Sub وهو عبارة عن تسجيل ماكرو لنسخ الخلايا من الشيت الاول الى آخر صف في الشيت الثاني مع خيار اللصق transpose ولا تنس أن تحفظ الملف بامتداد يدعم الاكواد مثل xlsb بالتوفيق

استخدم هذا المكود و لا تنسى اضافة اسماء الجداول في المتغيير On Error Resume Next If MsgBox("هل تريد افراغ الجداول المحدد ؟", vbExclamation + vbYesNo + vbMsgBoxRight, "تنبيه") = vbYes Then If InputBox("ادخل كلمة المرور لتأكد الحذف", "تأكيد افراغ الجداول") = "123" Then Dim db As DAO.Database Dim tdf As DAO.TableDef Dim NonTB1 As String NonTB1 = "table_name1" NonTB1 = (NonTB1 + ",") & "table_name2" NonTB1 = (NonTB1 + ",") & "table_name3" Set db = CurrentDb For Each tdf In db.TableDefs If Not (tdf.Name Like "MSys*" Or tdf.Name Like "~*" Or tdf.Name Like "exl*") Then If tdf.Name <> Split(NonTB1, ",")(0) And tdf.Name <> Split(NonTB1, ",")(1) And tdf.Name <> Split(NonTB1, ",")(2) Then sSQL = "DELETE FROM " & tdf.Name db.Execute sSQL End If End If Next MsgBox "تم افراغ الجداول المحددة بنجاح", vbMsgBoxRight + vbInformation, "تأكيد" End If End If

يمكنك استعمال هذا الإجراء وربطه بشكل أو زر في شيت سجل قيد بيانات Sub mas_getdata() Dim sh As Worksheet, n As Long, lr As Long, lr2 As Long Set sh = Sheets("data") lr = sh.Cells(Rows.Count, 2).End(xlUp).Row Application.ScreenUpdating = 0 Range("b17:s218").ClearContents For n = 9 To lr If sh.Range("f" & n) = [e2] And sh.Range("g" & n) = [e3] Then lr2 = Cells(Rows.Count, 2).End(xlUp).Row + 1 lr2 = IIf(lr2 < 17, 17, lr2) For c = 2 To 19 Cells(lr2, c) = sh.Cells(n, Cells(1, c)) Next c End If Next n Application.ScreenUpdating = 1 MsgBox "Done by mr-mas.com" End Sub ملحوظة: تم استخدام الأرقام في الصف الأول في الكود فلا يجب مسحها يمكن إخفاء الصف بالتوفيق

تفضل هذا التعديل شامل لكل ما طلبت سوف تتمكن من اختيار الجداول التي ترغب في افراغ البيانات منها الرقم السري داخل الكود لإفراغ البيانات 123 T2t2.accdb

وعليكم السلام ورحمة الله وللاكاته افضل اخي الكريم If DCount("[invoice]", "[Table1]", "[invoice] =" & Me.qty) > 0 Then MsgBox "رقم الفاتورة مكرر" End If تحياتي

وهذا برنامج ايضا للبحث ويقوم بعرض عدد مرات تكرار الكلمة في القران وايضا لو ضغط دبل كللك على الايه ينسخها لك بشكل تقرير ويمكن نسخ الاية للحافظة لنقلها للوورد مثلا للأمانه البرنامج منقـــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــول Holy_Quran.rar

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

If MsgBox(" هل تريد حفظ السجل ؟ ", vbYesNo, " تنبيه ") -= vbNo Then Cancel = True SendKeys "{ESC}" Exit Sub End If

تفضل ... zaBarCode_Items.mdb

ايضا مشاركة مع اخي الاستاذ @محمد أبوعبدالله تفضل ... Public Function CountChar() As Integer Dim StringToSearch As String, Character As String StringToSearch = Me.txtTest CountChar = 0 For i = 1 To Len(StringToSearch) ms = Mid(StringToSearch, i, 1) Strr = Nz(DLookup("n", "Tbl1", "[l] = '" & ms & "'")) Strr2 = Strr2 + Strr Me.kan = Strr2 Next i End Function تم استدعاء الكود ... Call CountChar kan_1238.mdb

جرب هذا الكود ... ضعه بعد امر الطباعة .... ملاحظة لم اجرب الكود Reports("فاتورة").Printer.PaperSize = acPRPSB5 acPRPSB5 يمثل ورق B5 و acPRPSA4 يمثل ورق A4 جرب واعلمنا بالتجربة ...

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

بكل بساطة اعكس العملية Dim LastRow As Long LastRow = ThisWorkbook.Sheets("xx").Range("g1").End(xlDown).Row LastRow = LastRow + 1

روعة استاذ @kanory فقد تعرف على ملف الاستاذ صاحب المشاركة واظهر بانه ملف اكسس

مصر ام الدنيا في الثقافة والعلم .. فاول مكتبة عملاقة في التاريخ هي مكتبة الاسكندرية تستطيع ان تكون خبيرا بالاجتهاد والمثابرة وانا ارى فيك تلك الروح المثابرة .. لكن نصيحتى لا تتعود على النسخ واللصق .. اي كود يمر عليك ادرسه بشكل جيد واسأل عن اي شي لم تفهمه فليس عيبا ان تسال .. لكن العيب ان يبقى الانسان جاهلا (حاشاك طبعا) بالتوفيق يارب

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

حبيبي استاذ قاسم الله يساعدك وجل من لا يخطا

كلامك صحيح استاذ حسام ربما اصبح لدي اشتباه بين or و And يستطيع الاخ صاحب المشاركة تعديلها اليك التعديل حسب مقترح استاذ حسام Q.accdb

السلام عليكم كود جميل استاذ قاسم لكن ملاحظة ارجو تقبلها في الشرط الثالث If M = 1 Or M <= 10 Then m=1 ليسلهاداعي لان الجزء الثاني من الشرط يحقق m=1 والافضل كتابتها كالاتي If M <= 10 Then كذلك طلب الاخ هي الارقام المحصورة بين 1و10 لذا تكتب كالاتي If M >= 1 and M <= 10 Then وعذرا للاطالة

If M = 1 Or M <= 10 Then لو القيمة مش بتساوى اى ارقام من 1 الى 10 تظل النتيجه كما هى

شكرا لك سيدي محمد صالح سيدي محمد صالح هل استطيع ان ابعث لك ملف موظفين لمؤسسة من اجل جلب تواريخ الغيابات واعدادها من فضلك ؟

ما شاء الله رووووعة

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

يعني ما تحتاج نوع الحساب او كيف ما فهمت هذي النقطة

تدري انه جاهز و في بداية البرنامج سويته و انت اعترضت عليه فأزلت الارتباط له من الصفحة الرئيسية و الآن بعد مرور هذي المدة طلعت تحتاجه

وعليكم السلام ورحمة الله وبركاته لمعرفة امتداد الملف استخدم الكود التالي Dim File_Type As String Dim DB_Full_Name As String DB_Full_Name = CurrentProject.Path & "\" & CurrentProject.Name File_Type = Mid(DB_Full_Name, InStrRev(DB_Full_Name, ".") + 1) Debug.Print File_Type ولمعرفة مسار الملف استخدم الكود التالي Debug.Print CurrentProject.Path ولمعرفة اسم قاعدة البيانات CurrentProject.Name ولمعرفة اسم قاعدة البيانات مع المسار كاملا استخدم الكود التالي Debug.Print CurrentProject.Path & "\" & CurrentProject.Name تحياتي

امين يارب ... واياكم

انت في منتدى كله خبراء وانا تلميذ لديهم انظر هل هذا جزء من اكوادك ..... Private Sub btnActivate_Click() Solved = CLng(Me.txtNum) If IsNumeric(Me.txtKey) = True Then If CLng(Nz(Me.txtKey, 0)) = 123456789 Then If Len(Me.txtCode) = 9 Then If Left(Me.txtCode, 1) = "i" Or Left(Me.txtCode, 1) = "c" Then If Right(Me.txtCode, 1) = "x" Or Right(Me.txtCode, 1) = "o" Then If IsNumeric(Mid(txtCode, 5, 1)) = True Then If IsNumeric(Mid(Me.txtCode, 3, 1)) = True Then If IsNumeric(Mid(Me.txtCode, 7, 1)) = True Then mNum = (Val(Mid(Me.txtCode, 3, 1)) + Val(Mid(txtCode, 5, 1)) + Val(Mid(Me.txtCode, 7, 1))) - 1 DLOldKey = Nz(DLookup("[OldKey]", "tblSetting"), 0) If Me.txtCode <> DLOldKey Then DoCmd.SetWarnings False DoCmd.RunSQL "Update tblSetting Set tblSetting.BaseDate=#" & Format(Date, "yyyy/mm/dd") & "#" DoCmd.RunSQL "Update tblSetting Set tblSetting.ActiveDate=#" & Format(DateAdd("m", mNum, Date), "yyyy/mm/dd") & "#" DoCmd.RunSQL "Update tblSetting Set tblSetting.OldKey='" & Me.txtCode & "'" DoCmd.SetWarnings True MB = MsgBox("Êã ÊÝÚíá ÇáäÙÇã ÈäÌÇÍ" & vbNewLine & "ÓÇÑí ÍÊì: " & DateAdd("m", mNum, Date), vbInformation, "Êã ÇáÊÝÚíá!") DoCmd.Close DoCmd.OpenForm "frmMainLogin" Else Me.txtCode = "" MB = MsgBox("ßæÏ ÊÝÚíá ãäÊåí ÇáÕáÇÍíÉ¡ ÈÑÌÇÁ ÇáÊæÇÕá ãÚ ÇáãØæÑ" & vbNewLine & vbNewLine & "01018877763 - 01201456588", vbCritical, "ÝÔá ÇáÊÝÚíá!") Me.txtCode.SetFocus End If Else Me.txtCode = "" MB = MsgBox("ßæÏ ÊÝÚíá ÛíÑ ÕÍíÍ¡ ÈÑÌÇÁ ÇáÊæÇÕá ãÚ ÇáãØæÑ" & vbNewLine & vbNewLine & "01018877763 - 01201456588", vbCritical, "ÝÔá ÇáÊÝÚíá!") Me.txtCode.SetFocus End If Else Me.txtCode = "" MB = MsgBox("ßæÏ ÊÝÚíá ÛíÑ ÕÍíÍ¡ ÈÑÌÇÁ ÇáÊæÇÕá ãÚ ÇáãØæÑ" & vbNewLine & vbNewLine & "01018877763 - 01201456588", vbCritical, "ÝÔá ÇáÊÝÚíá!") Me.txtCode.SetFocus End If Else Me.txtCode = "" MB = MsgBox("ßæÏ ÊÝÚíá ÛíÑ ÕÍíÍ¡ ÈÑÌÇÁ ÇáÊæÇÕá ãÚ ÇáãØæÑ" & vbNewLine & vbNewLine & "01018877763 - 01201456588", vbCritical, "ÝÔá ÇáÊÝÚíá!") Me.txtCode.SetFocus End If Else Me.txtCode = "" MB = MsgBox("ßæÏ ÊÝÚíá ÛíÑ ÕÍíÍ¡ ÈÑÌÇÁ ÇáÊæÇÕá ãÚ ÇáãØæÑ" & vbNewLine & vbNewLine & "01018877763 - 01201456588", vbCritical, "ÝÔá ÇáÊÝÚíá!") Me.txtCode.SetFocus End If Else Me.txtCode = "" MB = MsgBox("ßæÏ ÊÝÚíá ÛíÑ ÕÍíÍ¡ ÈÑÌÇÁ ÇáÊæÇÕá ãÚ ÇáãØæÑ" & vbNewLine & vbNewLine & "01018877763 - 01201456588", vbCritical, "ÝÔá ÇáÊÝÚíá!") Me.txtCode.SetFocus End If ElseIf Me.txtCode = "ÊÓÊ íÇ Úã" Then Me.txtCode = "" MB = MsgBox("Êã ÊÝÚíá ÇáäÙÇã ãÄÞÊÇ", vbInformation, "Êã ÇáÊÝÚíá!") DoCmd.Close DoCmd.OpenForm "frmMainLogin" Else Me.txtCode = "" MB = MsgBox("ßæÏ ÊÝÚíá ÛíÑ ÕÍíÍ¡ ÈÑÌÇÁ ÇáÊæÇÕá ãÚ ÇáãØæÑ" & vbNewLine & vbNewLine & "01018877763 - 01201456588", vbCritical, "ÝÔá ÇáÊÝÚíá!") Me.txtCode.SetFocus End If Else Me.txtKey = "" MB = MsgBox("ãÝÊÇÍ ÇáÊÝÚíá ÛíÑ ÕÍíÍ¡ ÈÑÌÇÁ ÇáÊæÇÕá ãÚ ÇáãØæÑ" & vbNewLine & vbNewLine & "01018877763 - 01201456588", vbCritical, "ÝÔá ÇáÊÝÚíá!") Me.txtKey.SetFocus End If Else Me.txtKey = "" MB = MsgBox("ãÝÊÇÍ ÇáÊÝÚíá ÛíÑ ÕÍíÍ¡ ÈÑÌÇÁ ÇáÊæÇÕá ãÚ ÇáãØæÑ" & vbNewLine & vbNewLine & "01018877763 - 01201456588", vbCritical, "ÝÔá ÇáÊÝÚíá!") Me.txtKey.SetFocus End If End Sub

يجب عرض التقرير بهذه الطريقة ثم الطباعة ليعمل الكود على تغيير خصائص الصفحة DoCmd.OpenReport "Labels_Table1", acViewPreview Reports("Labels_Table1").Printer.PaperSize = acPRPSB5

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

لاحظ التقرير .... بعد التعديل ..... اما بالنسبة للوقت هناك خطأ لديك وهو انك جعلت الحقل الخاص بالوقت نص المفروض تجعله وقت وتاريخ حتى يمكن جمع الساعات والدقائق ويمكن ان تساوي يوما في حالة التاخر حتى يتم الخصم على الموظف يوم في حال اكتمالها يوما .... Dawam1 (1)1.accdb

هل هذا ماتريد؟؟؟؟ انظر النموذج ..... كلمة المرور هي نفسها mohd1234 Dawam1 (1)1.accdb

الله يسلمك على رأسي والله انك استفدت شكرا لك

بالاضافة الى ما تفضل به استاذنا الفاضل @د.كاف يار وله جزيل الشكر تفضل اخي الكريم جرب الكود التالي Dim strFolderPath As String Dim DB_Full_Name As String Dim DB_Name As String Dim Backup_Full_Name As String Dim Copy_File As Variant Dim DB_Directory As String strFolderPath = CurrentProject.Path & "\Backup\" ' التاكد من وجود مجلد Backup ' اذ لم يكن موجود يتم انشائه If Len(Dir(strFolderPath, vbDirectory)) = 0 Then MkDir strFolderPath End If ' تحديد قاعدة البيانات DB_Full_Name = CurrentProject.Path & "\" & CurrentProject.Name ' تحديد مسار قاعدة البيانات DB_Directory = CurrentProject.Path ' تحديد اسم قاعدة البيانات DB_Name = CurrentProject.Name ' تحديد مسار النسحة الاحتياطية Backup_Full_Name = strFolderPath & Left(DB_Name, Len(DB_Name) - 6) & Format(Date, "yyyy-mm-dd") & "-" & Format(Now(), "Hh-Nn-Ss-AMPM") & ".accde" If MsgBox("هل تريد اجراء نسخة احتياطية من البرنامج؟", vbQuestion + vbYesNo, "نسخة احتياطية") = vbYes Then Set Copy_File = CreateObject("Scripting.FileSystemObject") Copy_File.copyfile DB_Full_Name, Backup_Full_Name, True End If تحياتي

يمكنك استخدام هذه المعادلة =INDEX($B$2:$E$5,MATCH($J3,$A$2:$A$5,0),COUNTA(B2:E2)) البحث عن اخر قيمة فى الصف.xlsm

أما أنا فأحمد الله أنك لم تفعل ذلك! لأن طريقتك أجود في نظري! أتمنى لك التوفيق

هل تعلم أن نسخ المعادلات في إكسل 2003 كان بهذا الكود Selection.AutoFill Destination:=Range("c4:c20"), Type:=xlFillDefault وكان يستهلك من ذاكرة الجهاز قدرا كبيرا أما في إكسل 2007 جرب هذا الكود Selection.FillDown وذلك طبعا بعد تحديد الخلية في الحالتين Range("c4:c20").Select ويمكنك ايضا استعمال fillright fillleft fillup تحياتي للجميع