Foksh

تم نقل مشاركتك الى موضوع جديد

حسناً أخي الكريم ، ولا يهمك .. بسيطة جرب هذا التعديل على قاعدتك التي تحتوي بيانات أكبر ، وتأكد من أخذ نسخة احتياطية منها ( أو نسخة أخرى اعملها للتجربة ) :- Private Sub أمر1069_Click() On Error GoTo ErrorHandler Dim db As DAO.Database Dim rsSource As DAO.Recordset Dim rsDest As DAO.Recordset Dim strSQL As String Dim currentCode As Long DoCmd.SetWarnings False Set db = CurrentDb db.Execute "DELETE FROM tab_degree_mauel", dbFailOnError db.Execute "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", dbFailOnError strSQL = "SELECT t1.code_fonct, t1.nom_prenom, t1.degre, t1.numero_indice_degre, t1.date_effet " & _ "FROM tab_degree_saisie t1 " & _ "INNER JOIN (SELECT nom_prenom, MAX(degre) AS MaxDegre " & _ "FROM tab_degree_saisie " & _ "GROUP BY nom_prenom) t2 " & _ "ON t1.nom_prenom = t2.nom_prenom AND t1.degre = t2.MaxDegre" Set rsSource = db.OpenRecordset(strSQL, dbOpenDynaset) If Not (rsSource.EOF And rsSource.BOF) Then rsSource.MoveFirst Do Until rsSource.EOF currentCode = Nz(rsSource!code_fonct, 0) Set rsDest = db.OpenRecordset("SELECT * FROM tbl_info_fonctionnaire WHERE num = " & currentCode, dbOpenDynaset) If rsDest.EOF Then rsDest.AddNew rsDest!num = currentCode Else rsDest.Edit End If rsDest!grade = rsSource!degre rsDest!num_indice_grade = Nz(rsSource!numero_indice_degre, 0) rsDest!date_effet_grade_actuel = Nz(rsSource!date_effet, Date) rsDest.Update rsDest.Close rsSource.MoveNext Loop End If MsgBox "تم تحديث البيانات بنجاح", vbInformation + vbMsgBoxRight, "" Cleanup: On Error Resume Next If Not rsSource Is Nothing Then rsSource.Close Set rsSource = Nothing End If If Not rsDest Is Nothing Then rsDest.Close Set rsDest = Nothing End If Set db = Nothing DoCmd.SetWarnings True Me.Requery Exit Sub ErrorHandler: MsgBox "حدث خطأ: " & Err.Description, vbCritical + vbMsgBoxRight, "خطأ" Resume Cleanup End Sub

وعليكم السلام ورحمة الله وبركاته ,, هذه محاولة بسيطة قد لا تكون بدقة فكرة الأستاذ @hegazee :- Private Sub Worksheet_Change(ByVal Target As Range) Dim c As Range, val As String Dim regex As Object Set regex = CreateObject("VBScript.RegExp") regex.Pattern = "^\d{1,2}-([a-zA-Z][1-9]\d*|[1-9]\d*[a-zA-Z]?)$" For Each c In Intersect(Target, Columns("E")) If Not IsEmpty(c) Then val = c.Value If Not regex.Test(val) Or Len(val) > 8 Then MsgBox "صيغة غير صحيحة! يجب أن تكون:" & vbCrLf & vbCrLf & _ "تستخدم شرطة (-) فقط (.1)" & vbCrLf & _ "لا تبدأ الأرقام بصفر (.2)" & vbCrLf & _ "لا يوجد صفر بعد الحرف الإنجليزي (.3)" & vbCrLf & _ "(12-a1234 :مثال ) الحد الأقصى 8 أحرف (.4)", _ vbExclamation + vbMsgBoxRight, "تصحيح" Application.Undo End If End If Next c End Sub جربها وأخبرنا بالنتيجة ..

وعليكم السلام ورحمة الله وبركاته ,,, تمام فهمتك ، جرب التعديل ده :- 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