كل الانشطه

أخواني وأساتذتي ومعلمينا ( دون استثناء ) أشارككم في هذا الموضوع أداة بسيطة وفعالة قمت بتطويرها لأغراض إنشاء واستعادة نسخ احتياطية من قواعد بيانات اكسيس . ✔️ الهدف الأساسي من الأداة هو توفير طريقة مرنة وآمنة لأخذ نسخ احتياطية من الجداول المهمة بشكل دوري أو عند الحاجة ، وتسهيل استعادتها لاحقاً بنفس البنية والبيانات . صورة من واجهة الأداة :- الواضح من الواجهة ، أن الأداة ستمكنك من :- أولاً :- إنشاء نسخة احتياطية ضمن الإعدادات التي تحددها في زر "خيارات الحفظ" . عند النقر عليه ستجد هذه الإعدادات في الصورة .. مسار الحفظ للنسخ الإحتياطية سيكون فقط في المجلد Backup في المجلد الرئيسي Data الموجود بجانب قاعدة البيانات . نوع الملحق سيكون MDB و DAT . وهما النوعين الأكثر شمولاً واستخداماً في جميع الأفكار التي لها نفس الوظيفة . عدد النسخ التي ستحتفظ بها هو فقط ما تحدده . وسيتم حذف النسخ الأقدم تباعاً . بإمكانك تحديد كلمة مرور لحماية قاعدة بيانات الجداول . ولا ننصح بتغييرها لكل نسخة كي لا تتوه وتفقد بياناتك . إمكانية النسخ التلقائي حسب عدد الأيام أو الساعات الي تريد أخذ نسخة تلقائية فيه . ثانياً :- إنشاء نسخة احتياطية لجداول تقوم بتحديدها - ولك حرية اختيار الجداول في كل نسخة - حيث أنها لن تؤثر على سير عملية الإسترجاع لاحقاً . انظر الصورة للتوضيح :- على اليمين تظهر أسماء الجداول في القاعدة الحالية ( مرتبطة أو محلية ) . ولك الحرية باختيار جداول محددة بالنقر المزدوج على الجدول ، أو تحديد الكل / إلغاء الكل . حسب حاجتك . ثالثاً :- الأزرار كما هي في صورة واجهة الأداة ، تشير إلى :- زر "حفظ نسخة إحتياطية جديدة" :- لإنشاء نسخة إحتياطية حسب الإعدادات اتي تم تحديدها . زر "تحديث بيانات النُسخ الإحتياطية" :- لإعادة ترتيب السجلات في الجدول حسب النسخ الموجودة في مجلد انسخ الإحتياطي . زرا "نُسخ محددة" و "كافة النُسخ" :- لحذف محدد أو لجميع النسخ الإحتياطية . زر "إنشاء" في قسم "نسخة خاصة" :- مخصص لإنشاء نسخة خاصة في مكان يقوم المستخدم بتحديده وليس ضمن المسار المحدد في الإعدادات ، وبإسم متغير كيفما يريد . زر "استرجاع" في قسم "نسخة خاصة" :- مخصص لإسترجاع نسخة يقوم المستخدم بتحديدها بشكل يدوي من خلال مربع حوار اختيار ملف . زر "استرجاع" في قسم "استرجاع النسخة رقم" :- مخصص لاختيار نسخة محددة برقمها . حيث تظهر النسخ التي تم أخذها إحتياطياً ، في أعلى جزء النموذج والتنقل بينها من خلال الزرين < > . رابعاً :- في هذا الإصدار ( V1.0 ) من الأداة على عدم الإعتماد على أي مكتبات خارجية أو من مكتبات أكسيس . حيث تمت التجربة على إصدارات اكسيس ( 2010 فما فوق ) . Backup 2025 - V1.0.accdb.zip :- دائماً يسعدني إبدائكم الرأي والملاحظات حول الأخطاء والمشاكل التي يمكن مواجهتها في أي مشروع يتم تأسيسه في آكسيس أو غيره من لغات البرمجة .

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

وعليكم السلام ورحمة الله وبركاته ,, تفضل saffar2.zip

السلام عليكم ورحمة الله وبركاته.... لطفا هل تم غلق الموضوع؟؟

السلام عليكيم عند اختيار اسم الفرع من مربع تحرير وسرد يفتح النموذج ولا يظهر الاسم الفرع الذي اخترته saffar2.accdb

وعليكم السلام ورحمة الله تعالى وبركاته جرب هل هدا ما تقصده Option Explicit Sub GetData() On Error GoTo EndClear Dim WS As Workbook, CrWS As Worksheet, dest As Worksheet, i As Long, tmp As Long Dim début As Long, tbl1 As Long, tbl2 As Long, ColArr As Variant, xPath As String ColArr = Split("1 2 3 4"): SetApp False Set dest = ThisWorkbook.Sheets("Sheet1"): xPath = ThisWorkbook.Path & "\aa.xlsb" If Dir(xPath) = "" Then MsgBox "الملف غير موجود: " & xPath, vbExclamation: GoTo CleanExit Set WS = Workbooks.Open(xPath) Set CrWS = WS.Sheets("Sheet1") If IsEmpty(dest.Cells(1, 1)) Then For i = 0 To UBound(ColArr) dest.Cells(1, i + 1).Value = CrWS.Cells(1, CLng(ColArr(i))).Value Next i End If début = 2: tbl1 = CrWS.Cells(CrWS.Rows.Count, "A").End(xlUp).Row: tmp = tbl1 - début + 1 If tmp <= 0 Then MsgBox "لا توجد بيانات للنسخ", vbExclamation: GoTo CleanExit tbl2 = dest.Cells(dest.Rows.Count, "A").End(xlUp).Row + 1 For i = 0 To UBound(ColArr) dest.Cells(tbl2, i + 1).Resize(tmp).Value = _ CrWS.Cells(début, CLng(ColArr(i))).Resize(tmp).Value Next i Application.Goto dest.Range("A1"), True CleanExit: If Not WS Is Nothing Then WS.Close False SetApp True If tmp > 0 Then MsgBox "تم ترحيل البيانات بنجاح", vbInformation Exit Sub EndClear: Resume CleanExit End Sub Private Sub SetApp(ByVal enable As Boolean) With Application .ScreenUpdating = enable: .EnableEvents = enable: .DisplayAlerts = enable .Calculation = IIf(enable, xlCalculationAutomatic, xlCalculationManual) End With End Sub ترحيل v2.rar

وعليكم السلام ورحمة الله وبركاته استكمالا لما تفضل به الأساتذة @Foksh و @hegazee من حلول مشكورة و إثراءا للموضوع أضع بين يديك اقتراحا إضافيا ربما قد يكون مناسبا لطلبك Private Sub Worksheet_Change(ByVal Target As Range) Const ColF As Long = 5, Irow As Long = 2, Max As Long = 5 Dim rng As Range, i As Long, ky() As String, Cnt$, tmp$, msg$, txt$ If Target.Column = ColF Then On Error GoTo Cleanup SetApp False For Each rng In Target txt = Trim(CStr(rng.Value)): msg = "" If txt = "" Then GoTo NextCell If InStr(txt, "/") > 0 Then msg = "(/) " & _ "خطأ: يرجى استخدام الشرطة العادية (-) بدلا من الشرطة المائلة" If msg = "" And InStr(txt, "-") = 0 Then msg = "خطأ: التنسيق غير صحيح" If msg = "" Then ky = Split(txt, "-") If UBound(ky) <> 1 Then msg = "خطأ: يجب أن يكون التنسيق بالشكل (رقم-رموز)" Else Cnt = ky(0): tmp = ky(1) If msg = "" And (Not IsNumeric(Cnt) Or Len(Cnt) < 1 Or Len(Cnt) > Irow) Then _ msg = "خطأ: الجزء الأول يجب أن يكون رقمًا مكونا من رقم أو رقمين فقط" If msg = "" And Len(tmp) > Max Then msg = "خطأ: الحد الأقصى للرموز بعد الشرطة هو 5 رموز" If msg = "" And Left(tmp, 1) = "0" Then msg = "خطأ: لا يسمح ببدء الجزء الثاني بصفر" For i = 1 To Len(tmp) - 1 If msg = "" And Mid(tmp, i, 1) Like "[A-Za-z]" And Mid(tmp, i + 1, 1) = "0" Then msg = "خطأ: لا يسمح بوجود صفر بعد الحرف الإنجليزي": Exit For End If Next i End If End If If msg <> "" Then MsgBox msg, vbCritical, "خطأ في إدخال رقم الحالة": rng.Value = "" NextCell: Next rng End If Cleanup: SetApp True End Sub Private Sub SetApp(ByVal enable As Boolean) With Application .ScreenUpdating = enable: .EnableEvents = enable: .DisplayAlerts = enable .Calculation = IIf(enable, xlCalculationAutomatic, xlCalculationManual) End With End Sub Book1 v2.xlsm

الاستاذ الفاضل حجازى @hegazee ما شاء الله رائع واسمح لى بطلب اضافة شرط ان يكون الحد الاقصى للارقام والحروف بعد الشرطة 5 والحد الاقصى للارقام قبل الشرطة 2 رقمين فقط تقبل تحياتى وشكرى الاستاذ الفاضل 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

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

تحية طيبة الأستاذ والأخ الكريم @Foksh أولا أعتذر على التأخير في الرد على الموضوع بعد التجربة أخي شغال ويؤدي المطلوب في هذا المثال: ربما أنا لم أعرف كيف أشرح طبقته على قاعدة البيانات التي اعمل عليها في جدول tbl_info_fonctionnaire الذي عندي به حقول كثيرة وانا اختصرته وابقيت على 6 حقول فالكود يقوم يقوم بحدف البيانات الموجودة السابقة في الجدول ويضيف الجديدة وأنا أريد اخي الابقاء على جميع البيانات السابقة في جدول tbl_info_fonctionnaire مع تحديث في الجدول للحقول المعنية فقط. وجزاك الله خيرا

وعليكم السلام ورحمة الله وبركاته ,, هذه محاولة بسيطة قد لا تكون بدقة فكرة الأستاذ @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 cell As Range Dim inputValue As String Dim parts() As String Dim secondPart As String Dim hasLetter As Boolean Dim letterPos As Integer Dim i As Integer Dim errorMsg As String ' التحقق من أن التغيير حدث في العمود E (العمود الخامس) If Not Intersect(Target, Me.Columns(5)) Is Nothing Then Application.EnableEvents = False ' تعطيل الأحداث مؤقتًا لتجنب التكرار For Each cell In Intersect(Target, Me.Columns(5)) If Not IsEmpty(cell) Then inputValue = Trim(cell.Value) errorMsg = "" ' التحقق من وجود الشرطة المائلة (/) If InStr(inputValue, "/") > 0 Then errorMsg = errorMsg & "خطأ: يجب استخدام الشرطة العادية (-) بدلاً من الشرطة المائلة (/)." & vbCrLf End If ' التحقق من التنسيق العام If InStr(inputValue, "-") > 0 Then parts = Split(inputValue, "-") If UBound(parts) = 1 Then secondPart = parts(1) ' التحقق من وجود صفر في بداية الجزء الثاني If Left(secondPart, 1) = "0" Then errorMsg = errorMsg & "خطأ: لا يُسمح بوجود صفر (0) بعد الشرطة (-)." & vbCrLf End If ' التحقق من وجود حرف إنجليزي في الجزء الثاني hasLetter = False letterPos = 0 For i = 1 To Len(secondPart) If secondPart Like "*[a-zA-Z]*" Then hasLetter = True Exit For End If Next i ' التحقق من وجود صفر بعد الحرف الإنجليزي (إن وجد) If hasLetter Then letterPos = InStr(secondPart, Left(secondPart, 1)) If letterPos > 0 And Mid(secondPart, letterPos + 1, 1) = "0" Then errorMsg = errorMsg & "خطأ: لا يُسمح بوجود صفر (0) بعد الحرف الإنجليزي." & vbCrLf End If End If Else errorMsg = errorMsg & "خطأ: تنسيق رقم الحالة غير صحيح. يجب أن يكون على شكل (أرقام-أرقام) أو (أرقام-حرف أرقام)." & vbCrLf End If Else errorMsg = errorMsg & "خطأ: يجب أن يحتوي رقم الحالة على شرطة عادية (-)." & vbCrLf End If ' إذا كان هناك خطأ، عرض رسالة تحذير وإلغاء الإدخال If errorMsg <> "" Then MsgBox errorMsg, vbCritical, "خطأ في إدخال رقم الحالة" cell.Value = "" End If End If Next cell Application.EnableEvents = True ' إعادة تفعيل الأحداث End If End Sub Book1.xlsm

وانا ويندوز 11 برضو بس حضرتك قلت بيشتغل عند ناس وناس لا اتمنى ما يشتغل عندى علشان احاول اعرف ايه المشكله

بارك الله فيك اخى الغالى مطلوب بعد فتح مستند aa نسخ sheet1 الى مستند bb ثم غلق مستند aa ترحيل.rar

السلام عليكم بالملف المرفق يقوم مدخل البيانات بادخال رقم الحالة باكثر من طريقة تم حصر الاخطاء كالاتى 1 - لا يستخدم الشرطة المائلة ( / ) كما فى الحالة الاولى .. وانما يستخدم الشرطة ( - ) كما فى باقى الحالات 2 - لا يكتب الصفر ( 0 ) بعد الشرطة ( - ) كما فى الحالة الثالثة و العاشرة 3 - لا يكتب الصفر ( 0 ) بعد الحرف الانجليزى ان وجد كما فى الحالة الخامسة وعند قيام مدخل البيانات بتنفيذ احد هذه المحظورات او كلها تظهر رسالة تصحيح ولا يتم الادخال Book1.xlsx

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

هو برنامج قديم كان يشتغل على الوندوز 10 ، ولا يشتغل على الوندوز 11. ولا تظهر هذه المشكلة للجميع ، وحتى حاولت تغيير الريجستري ، وبدون فائدة مافي فائدة ارفق لك نسخة ، لأنه اذا عمل على حاسبتك ، فما معروف اذا يعمل عندي !! الحاسبة عندي فيها وندوز 11 جديد ، مو تحديث من من الوندوز 10

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

اعرض الملف فتح أكثر من نسخة للنموذج تتفاعل مع النماذج الأخرى {سلسلة الأدوات المساعدة المخصصة} الأداة اليوم توضح طريقة فتح نسخ متعددة للنموذج وكيفية الإتصال مع النماذج الأخرى لإرسال وإستقبال القيم بينها بحيث تكون القيم الراجعة مختلفة بإختلاف النسخة التي تقوم بالإستدعاء مع تحياتي صاحب الملف منتصر الانسي تمت الاضافه 06/24/25 الاقسام قسم الأكسيس  

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

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