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

السلام عليكم ورحمة الله وبركاته الحمد لله الذي بفضله ونعمته تتم الصالحات الفضل لله أولاً ثم لإخوتي أحبتي الكرام الذين قاموا بمد يد العون والمساعدة في تصميم هذا البرنامج المتواضع القرآن الكريم وأسأل الله جل في علاه أن يجعله في موازين حسنات إخوتي أحبتي القرآن الكريم الخط العثماني.rar

فهمتك معلمي الفاضل .. بالطبع ، ويمكن تقييد المستخدم العادي من عدم الدخول أساساً الى لوحة النسخ الإحتياطي ( وهذا لا خلاف عليه ) في الأداة جعلتها قادرة على التعامل مع القواعد المنقسمة والغير .. وإذا كان النسخ الإحتياطي الذي نريده ان يتم على القاعدة لجميع الجداول ( عند محاولة استرجاع طبعاً ) محصوراً فقط بالجداول المحلية ، فلا أعلم الهدف ( والسبب أن 99% ممن يقوم بتقسيم قواعد بياناته هو لتجنب تلف وتضخم قواعد البيانات بسرعة ولحمابة البيانات والجداول ) . على العموم سأرى ما يمكن تفعيله وتعديله في النسخة الجديدة ان شاء الله أهلا مهندسنا الغالي ,, في الواقع ، من المفترض أن يتم انشاء المجلدات عند فتح الواجهة ، ولكن يبدو أنني لم أعد استدعاء الدالة الى حدث عند الفتح ,, لذا تم التعديل لاحقاً في النسخة الجديدة ان شاء الله 👍 الإسترجاع في الإصدار السابق محصور فقط للـ MDB ، وقد التعديل والتطوير في الإصدار الجديد أيضاً .. لكني هنا في طور استنتاج النقاط التي يمكن إضافتها وتحسينها 😊

شكرا لك حبيبنا @Foksh على هذي العطية الرائعة 🙂 موضوع قديم متجدد وباب الإبداع فيه والتنوع بحر لا ساحل له 😊🖐 وكل فنان وله بصمته فيه .. والأفكار كثيرة لا يمكن حصرها .. لذلك سأكتفي بالتجربة والاستمتاع بهديتك القيمة 😄🌹 فقط مما واجهني عند الضغط على زر ضبط مسار الحفظ بشكل آلي : .. المفروض ينعمل المجلد تلقائيا أليس كذلك ؟! لذلك زر الحفظ يظهر رسالة الخطأ التالية : أنشأت نسخة خاصة بالأمتداد Dat .. ولكن عند الاسترجاع : ملاحظة : النسخ الخاصة لا يتم حفظ بياناتها في الجدول !! وربما التلقائية كذلك (لم أجرب) .. أم هذا مقصود ؟ والباقي راائع كروعتك 😎👌

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

شكرا جزيلا أخي الفاضل وبارك الله فيك وزادك الله من علمه

السلام عليكم ورحمة الله وبركاته الكود المرفق في طلبك الاول لا يتناسب مع وافع الملف وخصوصا النطاقات K13:KJ - H14:H فهي ليس لها اهمية خسب ملفك المرفق اليك التعديل حسب فهمى لفكرة عمل ملفك يتم ما تم ترخيله باللون الاصفر ويمكن الغائها من الكود بحذف السطر w.Sheets("Galal").Cells(cell2.Row, c).Interior.Color = RGB(255, 255, 153) الكود Sub dahmour() Dim w As Workbook Dim L As Variant Dim r1 As Long, r2 As Long, c As Long Dim cell As Range, cell2 As Range Dim colNum As Long Dim matched As Boolean Dim rng As Range, cellDate As Range Set w = ActiveWorkbook L = w.Sheets("Sheet2").Range("D2").Value If L = "" Then MsgBox "يرجى اختيار التاريخ من الخلية D2!", vbExclamation Exit Sub End If r1 = w.Sheets("Sheet2").Cells(w.Sheets("Sheet2").Rows.Count, 1).End(xlUp).Row r2 = w.Sheets("Galal").Cells(w.Sheets("Galal").Rows.Count, 1).End(xlUp).Row Set rng = w.Sheets("Galal").Range("E7:Z7") c = 0 For Each cellDate In rng If IsDate(cellDate.Value) And IsDate(L) Then If CDate(cellDate.Value) = CDate(L) Then c = cellDate.Column Exit For End If End If Next cellDate If c = 0 Then MsgBox "لم يتم العثور على التاريخ '" & L & "' في الصف 7 من ورقة Galal", vbCritical Exit Sub End If If IsNumeric(w.Sheets("Sheet2").Range("K4").Value) Then colNum = w.Sheets("Sheet2").Range("K4").Value Else MsgBox "الخانة K4 يجب أن تحتوي على رقم العمود المراد ترحيله!", vbExclamation Exit Sub End If matched = False For Each cell In w.Sheets("Sheet2").Range("A11:A" & r1) If Trim(cell.Value) <> "" Then For Each cell2 In w.Sheets("Galal").Range("A8:A" & r2) If Trim(cell.Value) = Trim(cell2.Value) Then w.Sheets("Galal").Cells(cell2.Row, c).Value = w.Sheets("Sheet2").Cells(cell.Row, colNum).Value w.Sheets("Galal").Cells(cell2.Row, c).Interior.Color = RGB(255, 255, 153) matched = True Exit For End If Next cell2 End If Next cell If matched Then MsgBox "تم الترحيل بنجاح!", vbInformation Else MsgBox "لم يتم العثور على أي رقم جلوس مطابق!", vbExclamation End If End Sub الملف غياب1.xlsm

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

و أنتم بخير . جرب الكود التالي في الملف الأول Sub Button1_Click() Dim Wb1 As Workbook, Wb2 As Workbook, FilePath As String, OnRng As Range Dim WSdata As Worksheet, WSdest As Worksheet, WSname As String: WSname = "ملف 1" Application.ScreenUpdating = False Application.Calculation = xlCalculationManual With Application.FileDialog(msoFileDialogFilePicker) .Title = "اختر ملف Excel كمصدر للبيانات" .Filters.Clear: .Filters.Add "Excel Files", "*.xls; *.xlsx; *.xlsb" If .Show <> -1 Then MsgBox "لم يتم اختيار أي ملف", vbExclamation: Exit Sub FilePath = .SelectedItems(1) End With Set Wb1 = Workbooks.Open(FilePath) Set Wb2 = ThisWorkbook On Error Resume Next Set WSdata = Wb1.Sheets(WSname) Set WSdest = Wb2.Sheets(WSname) On Error GoTo 0 If WSdata Is Nothing Or WSdest Is Nothing Then MsgBox "لم يتم العثور على ورقة العمل", vbCritical Wb1.Close False Exit Sub End If ' تحديد النطاق من F9 إلى S609 Set OnRng = WSdata.Range("F9:S609") WSdest.Cells.UnMerge WSdest.Range("F9:S609").ClearContents ' مسح النطاق المحدد فقط OnRng.Copy With WSdest.Range("F9") .PasteSpecial xlPasteFormulas .PasteSpecial xlPasteFormats End With Application.CutCopyMode = False Application.Goto WSdest.Range("F9"), True Wb1.Close False Application.Calculation = xlCalculationAutomatic Application.ScreenUpdating = True MsgBox "تم نسخ البيانات بنجاح", vbInformation End Sub

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

الاساتذة الافاضل @Foksh و @hegazee و @محمد هشام تعجز الكلمات عن التعبير عن شكرى وامتنانى وتقديرى لمساهماتكم البناءة فهى ثلاث دروس تناولت موضوع واحد والله لهذا فخر لهذا المنتدى ان يظهر لنا هذه اللئالئ التى تنير عقولنا بهذه الحلول الفريدة جعله الله فى ميزان حسناتكم وزادكم من علمه وفضله

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

وعليكم السلام ورحمة الله وبركاته ,, هذه محاولة بسيطة قد لا تكون بدقة فكرة الأستاذ @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

بارك الله فيك أخي الكريم ، ونسأل الله لكم مزيداً من التقدم ..