Foksh

وعليكم السلام ورحمة الله وبركاته ,,, تمام فهمتك ، جرب التعديل ده :- Private Sub Worksheet_Change(ByVal Target As Range) Dim c As Range, valToCheck As Variant Dim duplicateFound As Boolean Dim lastRow As Long, i As Long On Error Resume Next Set c = Intersect(Target, Columns("E")) If c Is Nothing Then Exit Sub Application.EnableEvents = False valToCheck = c.Value If valToCheck <> "" Then lastRow = Cells(Rows.Count, "E").End(xlUp).Row duplicateFound = False For i = 1 To lastRow If i <> c.Row And Cells(i, "E").Value = valToCheck Then If WorksheetFunction.CountBlank(Range("K" & i & ":N" & i)) = 4 Then MsgBox "الحالة سبق ادخالها ولم يتم بشانها اجراء", vbExclamation + vbMsgBoxRight, "تنبيه" c.ClearContents duplicateFound = True Exit For End If End If Next i If Not duplicateFound Then Cells(c.Row, "D").Value = Date End If End If Application.EnableEvents = True End Sub

انا افتكرت ان الفكرة واضحة ، على العموم اجعل مصدر بيانات النموذج = الجدول trans وحدد لكل كومبوبوكس مكانه في الجدول هذا اذا كنت فاهمك صح طبعاً 😅

وعليكم السلام ورحمة الله وبركاته .. جرب هذه الفكرة أخي الكريم 😊 . Country.zip

وعليكم السلام ورحمة الله وبركاته ,, أخي الكريم ، بداية حتى تبدأ بداية سليمة ، حاول الإبتعاد عن الأسماء العربية لمكونات قاعدة البيانات . وأيضاً استخدام المسافة بين التسميات التي لها أكثر من كلمة .... إلخ من الأساسيات المهمة عند تصميم قواعد البيانات . على العموم .. في حدث قبل التحديث لمربع النص "اسم الصنف" ، استخدم الكود التالي البسيط دون تعقيد .. Private Sub اسم_الصنف_BeforeUpdate(Cancel As Integer) If DCount("*", "[جرد المستودع]", "[اسم الصنف] = '" & Me![اسم الصنف] & "'") > 0 Then MsgBox "هذا الصنف موجود مسبقاً", vbExclamation + vbMsgBoxRight, "": Cancel = True: Me.Undo End If End Sub منع التكرار.zip

الله يبارك فيك يا صديقي .. ونتمنى لكم المزيد من التقدم ان شاء الله ,, بشاااااروووو .. الله يبارك فيك يا قلب .. أخي لطفي ، الله يبارك فيك ، ونتمنى لكم التقدم أيضاً

وعليكم السلام ورحمة الله وبركاته ,, بناءً على ما فهمته من هذا الكم الهائل من المعطيات 😅 ، جرب هذا التعديل ، حيث تم التعديل عى كودك الأصلي ليصبح = Private Sub أمر1069_Click() On Error GoTo ErrorHandler DoCmd.SetWarnings False DoCmd.RunSQL "DELETE FROM tab_degree_mauel" DoCmd.RunSQL "INSERT INTO tab_degree_mauel(code_fonct, nom_prenom, grade_actuel, categorie, numero_indice_categorie, degre, numero_indice_degre, duree, date_effet, faid_31_12, date_signature_decision, date_reunion_comession, date_calcul_faid_31_12, num_decision) " & _ "SELECT code_fonct, nom_prenom, grade_actuel, categorie, numero_indice_categorie, degre, numero_indice_degre, duree, date_effet, faid_31_12, date_signature_decision, date_reunion_comession, date_calcul_faid_31_12, num_decision " & _ "FROM tab_degree_saisie" DoCmd.RunSQL "DELETE FROM tbl_info_fonctionnaire" DoCmd.RunSQL "INSERT INTO tbl_info_fonctionnaire(num, grade, num_indice_grade, date_effet_grade_actuel) " & _ "SELECT code_fonct, degre, numero_indice_degre, date_effet " & _ "FROM tab_degree_saisie t1 " & _ "WHERE degre = (SELECT MAX(degre) FROM tab_degree_saisie t2 WHERE t2.nom_prenom = t1.nom_prenom)" DoCmd.SetWarnings True Me.Requery MsgBox "تم تحديث البيانات في الجدولين بنجاح", vbInformation + vbMsgBoxRight, "تنبيه" Exit Sub ErrorHandler: DoCmd.SetWarnings True MsgBox " : حدث خطأ أثناء تنفيذ العملية " & Err.Description, vbCritical + vbMsgBoxRight, "خطأ" End Sub أخبرنا بالنتيجة baseZ.zip

وعليكم السلام ورحمة الله وبركاته ,, لم اجد الكود الذي تتحدث عنه ،ولكن قم بالتعديل للدالة التي في الملف السابق الى التالي :- Private Sub Worksheet_Change(ByVal Target As Range) Dim c As Range, valToCheck, foundCell As Range Dim duplicateFound As Boolean On Error Resume Next Set c = Intersect(Target, Columns("E")) If c Is Nothing Then Exit Sub Application.EnableEvents = False valToCheck = c.Value If valToCheck <> "" Then Set foundCell = Columns("E").Find(valToCheck, LookIn:=xlValues) If Not foundCell Is Nothing And foundCell.Row <> c.Row Then If WorksheetFunction.CountBlank(Range("K" & foundCell.Row & ":N" & foundCell.Row)) = 4 Then MsgBox "الحالة سبق ادخالها ولم يتم بشانها اجراء", vbExclamation + vbMsgBoxRight, "تنبيه" c.ClearContents duplicateFound = True End If End If If Not duplicateFound Then Cells(c.Row, "D").Value = Date End If End If Application.EnableEvents = True End Sub وأخبرني بالنتيجة

بسيطة أخي الكريم .. تم التعديل الى الكود التالي :- Private Sub ListBox1_Click() If ListBox1.ListIndex = -1 Then Exit Sub Sheets(ListBox1.Column(0)).Activate Cells.Interior.Pattern = xlNone With Range(ListBox1.Column(1)).EntireRow .Interior.Color = vbYellow .Cells(1, 1).Activate End With TextBox2.Value = ListBox1.Column(2) End Sub

وعليكم السلام ورحمة الله وبركاته .. كفكرة بسيطة ، جرب تعديل هذا الحدث :- Private Sub ListBox1_Click() Sheets(ListBox1.Column(0)).Activate Range(ListBox1.Column(1)).EntireRow.Select TextBox2.Value = ListBox1.Column(2) End Sub الى التعديل التالي :- Private Sub ListBox1_Click() If ListBox1.ListIndex = -1 Then Exit Sub Sheets(ListBox1.Column(0)).Activate Cells.Interior.Pattern = xlNone With Range(ListBox1.Column(1)) .Interior.Color = vbYellow .Activate End With TextBox2.Value = ListBox1.Column(2) End Sub قمت باختيار اللون الأصفر كمثال ، ولك الحرية بالتعديل على مزاجك

إما بإعادة تثبيت نسخة ويندوز 11 بتحديثات جديدة ، أو العودة الى الإصدار السابق ( ويندوز 10 ) ..

ما هو اصدار الأوفيس الذي تستخدمه بعد التحديث ؟؟

ما شاء الله ، إبدااااع جميل أستاذ منتصر ، هذه الدالة والفكرة فعلاً مفيدة عندما تريد إضافة علامة مائية مثل "مسودة" أو "سري" ، أو نسخة غير مدفوعة للبرامج التي تعتمد على المدة التجريبية .... أو أي نص آخر في خلفية التقرير .

ليس هناك من مشكلة أخي الكريم ، انا وجهتك الى الخطأ الحاصل في الملف والغير مقصود لربما .. ويبدو أنك قمت بتعديل المشاركة المشار اليها سابقاً ولم أنتبه لها .. جزاكم الله كل خير على متابعتكم

أثابك الله ، راجع ملفك الأخير في هذه المشاركة :-

في نفس النموذج أخي :- الموضع الأول :- Private Sub أمر8_Click() Public Function arTableName() As String arTableName = ChrW(1580) & ChrW(1583) & ChrW(1608) & ChrW(1604) & ChrW(32) & _ ChrW(1578) & ChrW(1587) & ChrW(1580) & ChrW(1610) & ChrW(1604) & ChrW(32) & _ ChrW(1575) & ChrW(1604) & ChrW(1603) & ChrW(1578) & ChrW(1576) End Function الموضع الثاني :- Private Sub أمر8_Click() Dim arTblName As String Dim maxGN As Long Dim arMsgPrompt As String Dim arMsgTitle As String Dim msgResponse As VbMsgBoxResult On Error GoTo ErrorHandler arTblName = arTableName maxGN = Nz(DMax("[No_Gard]", "[T_Gard]"), 0) arMsgTitle = "تأكيد تنفيذ الأمر" arMsgPrompt = "أنت على وشك تحديث حالة جميع الكتب باليومية" arMsgPrompt = arMsgPrompt & vbCrLf & "من كتب موجودة إلى كتب فاقد" arMsgPrompt = arMsgPrompt & vbCrLf & "لتأكيد الأمر أضغط موافق ، ولإلغائه أضغط إلغاء" msgResponse = MsgBox(arMsgPrompt, vbQuestion + vbOKCancel + vbMsgBoxRight, arMsgTitle) strSQL = "UPDATE [" & arTblName & "]" & vbCrLf & _ " SET [" & arTblName & "].CaseBook = ""فاقد""," & vbCrLf & _ " [" & arTblName & "].[G N] = " & maxGN & vbCrLf & _ " WHERE ((([" & arTblName & "].CaseBook)=""موجود"")" & vbCrLf & _ " AND (Not ([" & arTblName & "].title) Is Null)" & vbCrLf & _ " AND (([" & arTblName & "].searinumber) Between [forms]![F_GardBooks]![text]" & vbCrLf & _ " AND [forms]![F_GardBooks]![text2]))" & vbCrLf & _ " OR ((([" & arTblName & "].CaseBook)=""موجود"")" & vbCrLf & _ " AND (([" & arTblName & "].title) Is Null)" & vbCrLf & _ " AND (([" & arTblName & "].searinumber) Between [forms]![F_GardBooks]![text]" & vbCrLf & _ " AND [forms]![F_GardBooks]![text2]));" If msgResponse = vbOK Then DoCmd.SetWarnings False DoCmd.RunSQL strSQL DoCmd.SetWarnings True MsgBox "تم تحديث البيانات بنجاح والحمد لله" Else End If Exit Sub ErrorHandler: Debug.Print Err.Number; Err.Description End Sub

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

وعليكم السلام ورحمة الله وبركاته ,, راجع هذا الموضوع قد يوصلك الى نتيجة التحديثات التي طرأت عند التحديث من ويندوز 10 الى ويندوز 11 !!!

وعليكم السلام ورحمة الله وبركاته .. تفضل هذه الفكرة :- Private Sub Worksheet_Change(ByVal Target As Range) Dim c As Range, valToCheck, foundCell As Range On Error Resume Next Set c = Intersect(Target, Columns("E")) If c Is Nothing Then Exit Sub Application.EnableEvents = False valToCheck = c.Value If valToCheck <> "" Then Set foundCell = Columns("E").Find(valToCheck, LookIn:=xlValues) If Not foundCell Is Nothing And foundCell.Row <> c.Row Then If WorksheetFunction.CountBlank(Range("K" & foundCell.Row & ":N" & foundCell.Row)) = 4 Then MsgBox "الحالة سبق ادخالها ولم يتم بشانها اجراء", vbExclamation + vbMsgBoxRight, "تنبيه" c.ClearContents End If End If End If Application.EnableEvents = True End Sub Book1.zip

الفكرة ليست في إيجاد بدائل فقط ، الفكرة في إيجاد بدائل دائمة وليس مؤقته ..

فقط يلزمك تغيير السطر التالي :- .Fields.Append .CreateField("lejnah_id", dbText) الى التعديل التالي :- .Fields.Append .CreateField("lejnah_id", dbLong) للتعامل مع الحقل على انه رقمي بدلاً من نصي .. وسيكون التسلسل كرقم وليس كنص وبالتالي تحصل على طلبك 😇

رغم أن طريقتك في التصميم غريبة 😅 ، وتحتاج وقتاً لاستيعابها ، لكن تفضل ، جرب هذا التعديل : Data127.zip

وعليكم السلام ورحمة الله وبركاته ، بدلاً من الإستعلام المعقد الذي استخدمته ، كان لي فكرة أخرى وهي الإعتماد على جدول مؤقت .. تابع الخطوات التي شرحتها أعلاه ، وانقر زر "اختر التاريخ والصفوف او احدها ثم انقر" ، وتابع النتيجة إن كانت صحيحة ,, Data126.zip

اذا كان هذا العامل يعمل لأكثر من 15 ساعة ، فيمكن استثنائه من الشروط التي قيدنا بها العمل بحيث من خلال حقل Yes/No ان هذا العامل مستثنى !!! 🙄

جميل جداً ، جزاكم الله كل الخير معلمنا الفاضل على هذه الفكرة الجميلة الشاملة ,, كنت سابقاً استخدم فكرة بسيطة :- Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer) On Error Resume Next Dim newKeyCode As Integer Select Case KeyCode Case vbKeyDown DoCmd.GoToRecord , , acNext Case vbKeyUp DoCmd.GoToRecord , , acPrevious Case vbKeyRight newKeyCode = vbKeyLeft KeyCode = newKeyCode Case vbKeyLeft newKeyCode = vbKeyRight KeyCode = newKeyCode End Select End Sub Private Sub Form_Open(Cancel As Integer) Me.KeyPreview = True End Sub لكن بعد التوسع الكبير في العمل بما تقدمتم به من خلال الكلاس ، سأضطر لإعادة النظر بفكرتي المتواضعة 😅

وعليكم السلام ورحمة الله وبركاته ,, تفضل هذا التعديل :- DDCompanyLogos.zip