Leaderboard

تفضل هذا ملفك بعد التعديل لاحظ استعمال المعادلة في جلب اسم مالك الشقة بدلا من كتابته واستعمال رقم الصف كبديل للترقيم وتغيير تنسيق التاريخ والأرقام بالتوفيق مصروفات وايرادات1.xlsm

طيب ... شوف هذا التحايل .... NM.accdb

اتفضل هذا التعديل Database3.accdb

شكرا لكلماتك الطيبة أنا شخصيا لم اغير إلا فيما يحقق الشرط الخاص بك على اعتبار ان الكود يعمل معك قبل ذلك لذلك إذا كنت تقصد تحويل النص المكتوب في مربع النص إلى تاريخ يمكنك تعديل Me.TextBox16.Value في الشرط إلى cdate(Me.TextBox16.Value) تم تعديل الكود كاملا في المشاركة الأصلية بالتوفيق

وعليكم السلام وحمة الله وبركاته تفضل اخي الكريم اذا كان حقل NationalID رقم Set rs = CurrentDb.OpenRecordset("SELECT * FROM tblNational WHERE NationalID =" & cbjobNo) اذا كان حقل NationalID نص Set rs = CurrentDb.OpenRecordset("SELECT * FROM tblNational WHERE NationalID ='" & cbjobNo & "'") تحياتي

اتفضل هذي مشاركتي مع الشباب NM.zip

وعليكم السلام 🙂 وبسبب انك ما اعطيتنا معلومات كافية ، فاختر المثال الاول او الثاني ، وكلاهما على حدث "النقر المزدوج" : الاول للنقر المزدوج للنموذج ، والثاني للحقل : جعفر

تفضل هذا الكود فقط انسخ و الصق في ازرار النسخة الاحتياطية On Error GoTo ErrH Dim fso As Object Dim fldrname As String Dim fldrpath As String Set fso = CreateObject("scripting.filesystemobject") fldrpath = CurrentProject.Path & "\Backup" If Not fso.FolderExists(fldrpath) Then fso.createfolder (fldrpath) DoCmd.RunSQL "CREATE TABLE Backup (Backup_NO INT , Backup_Name VARCHAR (50) , Backup_Path VARCHAR (100), Backup_Date Date);" End If Dim MyFile, DstFile, DataName As String Dim Syso As Object MyFile = CurrentProject.FullName DataName= "Backup-" & Format(Now, "dd-mm-yyyy") & "-(" & Format(Now, "hh.nn.ss") & ")" DstFile = CurrentProject.Path & "\Backup\" & DataName & ".accdb" DBEngine.Idle Set Syso = CreateObject("Scripting.FileSystemObject") Syso.copyfile MyFile, DstFile Set Syso = Nothing Name DstFile As DstFile & ".ptc" DBEngine.CompactDatabase DstFile & ".ptc", DstFile Kill DstFile & ".ptc" Dim db As DAO.Database Dim MaxBackup_NO As Integer MaxBackup_NO = Nz(DMax("[Backup_NO]", "[Backup]"), 0) + 1 Dim rs As DAO.Recordset Set db = CurrentDb Set rs = db.OpenRecordset("Backup") With rs .AddNew ![Backup_NO] = MaxBackup_NO ![Backup_Name] = DataName ![Backup_Path] = DstFile ![Backup_Date] = Now() .Update End With rs.Close Set rs = Nothing MsgBox "تم انشاء قاعدة البيانات بنجاح", vbMsgBoxRight + vbOKOnly, "تاكيد" Exit Sub ErrH: Select Case Err.Number End Select

السلام عليكم Int([a1a]/[b1b]+0.5)

وعليكم السلام ورحمة الله وبركاته غير خاصية POP UP الى NO data.rar تحياتي

سبحان الله ، هذا المنتدى يحتاج إلى محكمين من خارجه حتى لا يضيع الطلبة والمبتدئون. هذا مثال للدالة التي نصحت بها ودالة الدكتور ، أرجو لصقه ثم تشغيل الإجاراءين لمعرفة الفرق بين النتائج ووقت التنفيذ. كود في قمة الإتقان لم أرى شبيها له قبله ولن يأتي بعده ، واللي يحب يعترض يقابلني سنة 2500 ميلادي. Function CountWkDay(ByVal Date1 As Long, _ ByVal Date2 As Long, _ WkDay As Byte) As Variant If Date1 <= Date2 Then Date1 = Date1 - 1 Else Date2 = Date2 - 1 End If Date1 = Fix((Date1 + (7 - WkDay)) / 7) Date2 = Fix((Date2 + (7 - WkDay)) / 7) CountWkDay = Abs(Date2 - Date1) End Function Function WkDayCount(VarDate As Date, enddate As Date) As Long 'دالة د. كاف يار Dim SFriday As Long Do While VarDate < enddate VarDate = DateAdd("D", 1, VarDate) If Weekday(VarDate, 2) = vbFriday Then SFriday = SFriday + 1 End If Loop WkDayCount = SFriday End Function Sub Test1() Dim Date1 As Date Dim Date2 As Date Date1 = DateSerial(2021, 7, 23) Date2 = DateSerial(2021, 7, 30) Debug.Print CountWkDay(Date1, Date2, vbFriday) Debug.Print WkDayCount(Date1, Date2) End Sub Sub Test2() Dim Date1 As Date Dim Date2 As Date Dim Start As Single Date1 = DateSerial(2021, 7, 23) Date2 = DateSerial(9000, 7, 25) Start = Timer Debug.Print CountWkDay(Date1, Date2, vbFriday), Timer - Start Start = Timer Debug.Print WkDayCount(Date1, Date2), Timer - Start End Sub

اتفضلوا البرنامج العملاء_والديون_اقساط_0777134668.accdb

اسماء الحقول اصبحت C1 و C2 و C3 ، واعمل خلفيتهم باللون الذي تحب ، وعند حدث بعد التحديث ، سيتم اختيار المربع الذي يحمل نفي الرقم ، بنفس لون الخلفية: استعمل هذا الكود : Private Sub Select_it(ctl As Control) For i = 1 To 32 If Me("[" & i & "]") = Me(ctl.Name) Then Me("[" & i & "]").BackColor = Me(ctl.Name).BackColor End If Next i End Sub Private Sub C1_AfterUpdate() Call Select_it(C1) End Sub Private Sub C2_AfterUpdate() Call Select_it(C2) End Sub Private Sub C3_AfterUpdate() Call Select_it(C3) End Sub . جعفر 1402.1.Random Numbers.accdb.zip

الآن فهمت انك تحتاج توليد الرقم داخل نطاق الرقمين اتفضل التعديل توليد رقم عشوائي.accdb

تفضل التعديل auto no-1.rar

كلامك صحيح أنا أستعمل التعبير في الاستعلام والتقرير بدلا من الحقل المحسوب في الجدول ولكن هذا ما يبحث عنه الأخ صاحب السؤال بالتوفيق

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

اعتقد بانها لا تصلح مع رقم تلقائي .. واذا اردنا ان نعملها مع رقم تلقائي فيجب ان نعملها بحقل نصي اخر يأخذ قيمته من الرقم التلقائي

السلام عليكم جرب هذا الكود = "E" & (Right(Nz(DMax("[FileNo]", "TblEmpl"), 100000), 6) + 1)

لا ليس ضروري ولكن وضعته للانتقال للسجل التالي ضعها بعد امر الحذف ولكن ليس بديل عنه تحياتي

سيكون بالشكل التالي Dim db As DAO.Database Dim rs As DAO.Recordset Set rs = CurrentDb.OpenRecordset("SELECT * FROM tblNational WHERE NationalID =" & cbjobNo) rs.Delete rs.MoveNext rs.Close Set rs = Nothing تحياتي

جرب هذه Set rs = CurrentDb.OpenRecordset("SELECT * FROM tblNational WHERE NationalID =" [cbjobNo])

تقريبا الخطأ في أن الشرط في زر الحفظ والتعديل هو If C Like TextBox6.Value & "*" Then وهذا يعني أن الخلية تشبه الرقم وبعده أي رقم آخر * وربما يكون الصواب If c = Val(Me.TextBox6) Then وهو يعني تساوي الرقم مع الرقم المكتوب في مربع النص بالتوفيق

المطلوب غير واضح لي هل تقصد: إذا تساوت قيمة خلية في العمود f في الشيت micro يتم الترحيل في نفس الصف الذي تساوت فيه (طبعا في شيت micro) ولا يقوم بالترحيل في شيت raw وإذا تساوت قيمة خلية في العمود f في الشيت raw يتم الترحيل في نفس الصف الذي تساوت فيه ولا يقوم بالترحيل في شيت micro ؟؟؟

السلام عليكم جرب الكود التالي Private Sub Form_Resize() DoCmd.Maximize End Sub تحياتي

يمكنك استعمال هذا الكود في حدث عند الضغط على الزر Private Sub CommandButton1_Click() Dim iRow As Long, Lastrow As Long, i As Long With ورقة1 Lastrow = .Cells(.Rows.Count, 7).End(xlUp).Row For r = 3 To Lastrow If .Cells(r, 7) = TextBox1.Value Then iRow = .Cells(Rows.Count, 4).End(xlUp).Offset(1, 0).Row .Cells(iRow, 3).Value = Me.TextBox1.Value .Cells(iRow, 4).Value = Me.TextBox2.Value MsgBox " لقد تم الترحيل بنجاح ", vbExclamation + vbMsgBoxRight, "تم الترحيل " GoTo 1 End If Next End With MsgBox "لايوجد هذا الاسمً ", vbInformation + vbMsgBoxRight, "تنبيه" 1: TextBox1.Value = "" TextBox2.Value = "" TextBox1.SetFocus End Sub بالتوفيق

لا أدري أين المشكلة عندك ولكن إذا كنت تريد تطبيق ذلك على ملف آخر بامتداد xlsb أولا تفتح شاشة الفيجوال بيسك داخل اكسل ثم تضيف موديول جديد وتلصق فيه الكود الذي يتحقق من رقم الماذربورد Function MBSerialNumber(Optional strComputer As String = ".") As String Dim v, vName, vUUID With GetObject("winmgmts:\\" & strComputer & "\root\cimv2") For Each v In .ExecQuery("SELECT * FROM Win32_ComputerSystemProduct", , 48) vName = v.Name: vUUID = v.UUID Next v End With MBSerialNumber = vName & ", " & vUUID End Function ثم تضغط دبل كلك على thisworkbook وتلصق هذا الكود في حدث عند فتح الملف Private Sub Workbook_Open() Dim strMB1 As String, strMB2 As String, strMB3 As String 'Put Your MotherBoard Serial strMB1 = "HP ProDesk 490 G1 MT, FF004080-EE39-11E3-BFF8-A0D3C13F35B2" strMB2 = "HP Compaq 8500 Elite SFF PC, BFDEF800-AF9A-11E0-0000-2C27D742989F" strMB3 = "HP Compaq 8500 Elite SFF PC, BFDEF800-AF9A-11E0-0000-2C27D742989F" Select Case MBSerialNumber Case strMB1, strMB2, strMB3 Exit Sub Case Else MsgBox ("Data Security Failure. This Workbook Will Close") ActiveWorkbook.Close 1 End Select End Sub ثم تقوم بحفظ التغييرات وتغلق وتفتح الملف مرة أخرى بالتوفيق

تقدر تستعمل النموذج الذي اعطيتك هنا: جعفر

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

جربتها قبل أن أرفع مثالي ولم تنجح ، لماذا؟ ، لأنها بكل بساطة سوف تختار الحقل وسيظل السجل ثابتا لا يتبدل.

كفو و بيض الله و جهك و كلنا انشاء الله مكملين لبعض و نستفيد و نفيد

ما دام ان الطريق يؤدي إلى روما بركب أنا وياك بسيارة خاصة يا د / كاف هههههههههههههههههه

اجعل القيمة الافتراضية لرقم القيد =DLast("[رقم_القيد]";"السيارات")+1 عذرا استاذ عبد اللطيف ..ظننتك تريد اخر سجل وليس اكبر سجل

هذا الأمر سوف ينقلك دائما لأول سجل ، جرب أن تتخلص منه.

Dim rA As Range For Each rA In Columns("d").SpecialCells(xlConstants, xlNumbers).Areas rA.Cells(rA.Cells.Count + 1).Formula = "=SUM(" & rA.Address & ")" Next rA يقوم بوضع نتيجة جمع مدى معين في اخر خلية فارغة اسفل المدى بعد تشغيل الموديول ومن ثم المدى التالي في نفس العمود وهكذا ارجو ان يكون مفيد للجميع ..اسف للتاخر بالرد

الغي كود التحديث الموجود في حدث عن الفتح في التقرير لأني وضعت الكود لك ضمن كود تصدير البيانات اتفضل التعديل 111School_It_0001.zip

وعليكم السلام ورحمة الله وبركاته تفضل اخي الكريم =Round([totol];0) كسر عشري.accdb تحياتي

تفضل يا غالي التجربة 1 - جدول به 3 حقول يحتوي على بيانات ما يقرب من ربع مليون سجل 2 - كود متنوع يقوم باستعلام الحاق بثلاث طرق 3 - النتائج مبهرة '1 CurrentDb.Execute "DELETE * FROM Table3" X = Timer DoCmd.SetWarnings False DoCmd.RunSQL "INSERT INTO Table3 ( text1, text2, text3 ) SELECT Table1.text1, Table1.text2, Table1.text3 FROM Table1;" DoCmd.SetWarnings True XTime = Timer - X XTime = Format(XTime, "#0.0####") Debug.Print "Time1 " & "==========> " & XTime '2 CurrentDb.Execute "DELETE * FROM Table3" X = Timer CurrentDb.Execute "INSERT INTO Table3 ( text1, text2, text3 ) SELECT Table1.text1, Table1.text2, Table1.text3 FROM Table1;" XTime = Timer - X XTime = Format(XTime, "#0.0####") Debug.Print "Time2 " & "==========> " & XTime '3 CurrentDb.Execute "DELETE * FROM Table3" X = Timer CurrentDb.Execute "Query1" XTime = Timer - X XTime = Format(XTime, "#0.0####") Debug.Print "Time3 " & "==========> " & XTime '4 CurrentDb.Execute "DELETE * FROM Table3" X = Timer Dim db As DAO.Database Dim rs As DAO.Recordset Dim rst As DAO.Recordset Set rs = CurrentDb.OpenRecordset("Table1") Set rst = CurrentDb.OpenRecordset("Table3") For i = 1 To rs.RecordCount rst.AddNew rst.Fields(0) = rs.Fields(0) rst.Fields(1) = rs.Fields(1) rst.Fields(2) = rs.Fields(2) rst.Update rs.MoveNext Next rs.Close Set rs = Nothing rst.Close Set rst = Nothing XTime = Timer - X XTime = Format(XTime, "#0.0####") Debug.Print "Time4 " & "==========> " & XTime Debug.Print "================================" db9.rar تحياتي

لا تظن ما ليس بي فلم أرد ولم أتحدث بسبب كلمة ( كما تريد ) لأنك قبل كل ذلك معلمي واستاذي وأقدرك واحترمك قبل كل شيء فالعين لا تعلى على الحاجب أما فهم المعنى فيختلف من إنسان إلى إنسان فعلماؤنا اختلفوا في كثير من الأمور كل حسب فهمه ألا نختلف انا وانت في فهم المقصد وأعتذر منك ومن الجميع لدخولنا في موضوع آخر

وهذه مشاركة مع اخي واستاذي العزيز استاذ جعفر بطريقة التنسيق الشرطي qqq.rar

نعم كان عبارة عن سؤال باستخدام اسلوب الاستفهام التعجبي وهو من الاساليب السبعة للاستفهام و من ذلك قوله تعالى " ما لهذا الرسول يأكل الطعام ويمشي في الأسواق " وقوله تعالى " كَيْفَ تَكْفُرُونَ بِاللَّهِ وَكُنتُمْ أَمْوَاتاً فَأَحْيَاكُمْ " وفي هذا النوع من الاستفهام لا يتطلب وضع العلامة " ؟ "

اشوفك تتسرّع في تعليقاتك !! ولو تغيّر التعليق الى سؤال ، فبتحصل على اجابات افضل 🙂 الهدف الاكبر من هذا الموضوع هو ، حماية البيانات : 1. اذا البيانات على السيرفر ، والاكسس متصل بجداوله في السيرفر ، فالرابط يكون مستمر بين الواجهة والجداول ، والشاطر يقدر يستعمل احد برامج "الشم" Sniffing والتوصل الى ما يشاء ، 2. بينما اتصالك بالكود للسيرفر وجلب البيانات ، ثم انقطاع الاتصال بالسيرفر ، يجعل الموضوع ذو امان اكثر 🙂 وللعلم ، فهناك العديد من الجهات التي تهتم بأمن البيانات ، تصر على ان تكون جميع كائناتها غير منضمه 🙂 جعفر

شكرا جزيلا اخوي حسام انك نبهتنا لخطأ التكرار ، واللي صعب معرفته غير انك تجعل الارقام من 1 الى 32 🙂 هذا تعديل الكود حقي : Private Sub cmd_Generate_Random_Click() Dim i As Integer Dim j As Integer Dim f As Integer Dim e As Integer Dim t As Single t = Timer 'احفظ سجل النموذج If Me.Dirty Then Me.Dirty = False f = Me.[f-no] e = Me.[e-no] For i = 1 To 32: Me("[" & i & "]") = 0: Next i For i = 1 To 32 Try_Again: Dim MyValue Randomize Timer MyValue = Int((e * Rnd) + f) '1. No Duplicates For j = 1 To i If Val(Me("[" & j & "]")) = MyValue Then GoTo Try_Again Next j '2 Smaller than, Or Greater than If MyValue < f Or MyValue > e Then GoTo Try_Again Else Me("[" & i & "]") = MyValue End If Next i Debug.Print Timer - t End Sub . وتلاحظ اني حسبت الوقت اللي الكود يأخذه في عمل اللازم ، ويمكن مقارنة سرعة الكود هذا مع كود اخوي حسين واخوي حسام 🙂 جعفر

السلام عليكم 🙂 الظاهر انك تتب طريقة خاصة في عمل فاتورة جديدة ، او انك وضعت الكود في حدث آخر !! لأن الكود الذي اعطيتك هو عينا نفس الكود الذي اعطاك الاخ خالد ، والاثنين يعطون تقرير برقم الفاتورة الموجودة في النموذج او النموذج الفرعي !! على العموم ، هذه صورة عن مكان الكود الذي وضعته انا : . وهذا تعديل بسيط لحفظ السجل قبل طباعة التقرير: Dim stDocName As String If Me.Dirty Then Me.Dirty = False stDocName = "re3" 'DoCmd.OpenReport stDocName, acNormal, , "[invo]=" & Me.invo DoCmd.OpenReport stDocName, acViewPreview, , "[invo]=" & Me.invo جعفر

جرب الامر Dim stDocName As String stDocName = "re3" DoCmd.OpenReport stDocName, acNormal, , "[invo]=" & Me.Parent!id الملف مرفق برنامجي.mdb

السلام عليكم الطريقتان لهما عيوب ومميزات ويختلف حسب حجم العمل وعدد المستخدمين وانصحك بزيارة هذا الموضوع ستجد به مناقاشات وحلول مفيدة باذن الله تحياتي

جزاكم الله خيرا على المساعدة وكل عام وحضراتكم بخير عيد أضحى سعيد

حسب فهمي للمطلوب يمكنك استعمال هذا الكود Private Sub CommandButton5_Click() If ActiveSheet.Name <> "data" Then Dim wslr As Integer, counter As Integer, ws As Worksheet Set ws = ThisWorkbook.Worksheets("data") wslr = ws.Cells(Rows.Count, 1).End(xlUp).Row For counter = 1 To wslr If ws.Cells(counter, 2) = TextBox1.Value Then ws.Cells(counter, 2).EntireRow.Delete counter = counter - 1 End If Next MsgBox "تم حذف الاسم" End If End Sub

السلام عليكم 🙂 الخطأ يقول ان الكائن tbl_dece لا يوجد في النموذج Data member not found) : . اذا تلاحظ اسم حاوية النموذج الفرعي في النموذج ، اسمها يطابق الاسم في الكود ، فلم تحصل على خطأ هنا : . ولكن اسم حاوية النموذج الفرعي في النموذج ، اسمها لا يطابق الاسم في الكود ، لذا فالاسم الموجود في الكود غير موجود في النموذج اصلا : . وهذه طريقة اخرى للتأكد بأن الكائن المذكور في الكود لا يوجد في النموذج : فعندك خيارين للحل: 2. يا انك تُبقي الكود كما هو ، وتغيّر اسم حاوية النموذج الفرعي الى : . 2. او انك تُبقي على اسم حاوية النموذج الفرعي كما هي ، وعليه يتغيّر الكود الى : . ولاحظت انه عندك نفس الكائن بعدة مسميات ، فانت تلخبط نفسك ، وستكون المشكلة اكبر في المستقبل لما تريد عمل اي تعديل !! اعطيه نفس اسم النموذج ، والسلام : . ونصيحة اخرى ، وهي تنسيق الكود ، فلما يكون الكود كله يبدأ من اول السطر ، فلا تعرف بداية ونهاية كل مجموعة ، بينما لما يكون منسّق هكذا ، فمن السهل معرفة البداية والنهاية بمجرد النظر في الكود ، ولا داعي لقراءة الكود لمعرفة بدايته ونهايته ، هكذا : Private Sub Form_Load() If DCount("*", "Tbl_bb", "م") < 1 Then Me![addnew].Enabled = True Me.Next.Enabled = False Me.previous.Enabled = False Me.dlet.Enabled = False Me![cmdcols].Enabled = True Me![Edit].Enabled = False Me![sav].Enabled = False Me![traghh].Enabled = False AllowAdditions = True AllowEdits = False AllowDeletions = False Me.tbl_promotion.Form.AllowEdits = False Me.tbl_promotion.Form.AllowDeletions = False Me.tbl_promotion.Form.AllowAdditions = False Me.tbl_Retr.Form.AllowEdits = False Me.tbl_Retr.Form.AllowDeletions = False Me.tbl_Retr.Form.AllowAdditions = False Me.tbl_dece.Form.AllowEdits = False Me.tbl_dece.Form.AllowDeletions = False Me.tbl_dece.Form.AllowAdditions = False End If End Sub جعفر

وعليكم السلام انا معلم ويهمني هذا الموضوع لذلك قمت بتصميم برنامج يوزع المعلمين علي قاعات الامتحان وسميته برنامج الملاحظة علي الامتحانات مع مراعاة ان كل معلم يدخل كل قاعة مرة واحدة بقدر الامكان تستطيع وضع مشرف لكل مادة بحيث يتم استيعادة من الملاحظة تستطيع وضع الاحتياط تستطيع وضع لجنة لجمع وترتيب الاوراق تستطيع وضع لجنة نظام تستطيع اعفاء بعض المعلمين من الملاحظة... الخ الخ ثم في النهاية طباعة الجداول المختلفة لا اطيل عليك فهناك ميزات اخري في اليرنامج تفضل جربه لعله يناسبك 1076052452_5.5.xlsm