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

الله يعافيك قمت بعمل تغيير بسيط بسيط بسيط جدا في الملف وهو أنه في كل قسم يوجد في الأعلى فرع1 , فرع1 , فرع1 , فرع2 , فرع2 , فرع2 الخ الخ الخ فأنا قمت بوضع الارقام فقط بدون كلمة فرع هكذا : 1 , 1 , 1 , 1 , 2 , 2 , 2 , 2 , 2 , 3 , 3 , 3 الخ الخ هذا هو التغيير الذي قمت به فقط حتى يتماشى مع المعطيات التي فرضتها في الكود طريقة العمل كالآتي : افتح ورقة ملخص اضغط الزر (ملخص) في الأعلى وأي أخطاء تظهر أعلمني بها تقبل تحياتيتجربة 1.xlsm تجربة 1.xlsm

يمكن تخطيه بشكل دائم وايضا جربت على الملف المرفق ويمكن خداع الكود وتيقى عدد مرات الفتح 1 مع ملاحظة اني لم ادخل على محرر الاكواد في المثالين فملف الاخ موسى محمي بكلمة مرور ومع سهولة كسرها كما تعلم ولكن لم احتاج الى ذلك وكذلك في مثالك لم تضع مرور على محرر الاكواد وايضا لم ادخل مطلقا على المحرر واكتفيت بحقن امر صغير ربما لو تم تحويل الملف الى accde سيكون الامر اكثر صعوبة الشايب

برأيي المتواضع ، اعتقد تحديد عدد سجلات محدد كإدخال للبيانات أمر كما أوضح أستاذنا @شايب ، يمكن تخطيه ضمن نفس الجلسة ,( حتى لو نسبة وإحتمالية الثغرة 1% ), لكنها قابلة للحدوث ، لذا أتوجه بعدم إلزام المستخدم بعدد محدد ، وأتجه لإتجاه آخر وهو عدد مرات الفتح ، أو النسخة التجريبية التي استخدمها حالياً في معظم مشاريعي والتي تعتمد على الريجستري + جوانب أخرى لمتابعة النسخة التجريبية حتى لو بعد الفورمات !!! وهذه محاولتي المتواضعة اوفسنا كود ايقاف_فوكش.accdb

طيب خليني أشارك على طريقتي 🙂 جرب تدخل أكثر من 3 سجلات وشوف ... وإذا كملت 3 سجلات إحذفهم كلهم أو إحذف شي منهم وجرب تضيف سجلات جديدة .. وحاول أنك تلغي هذا النظام لو أمكن .. 💪🏻 🙂 ‏‏Trial_Version_Moosak - Test.accdb

وعليكم السلام ورحمة الله تعالى وبركاته جرب هدا Sub ExportPDF_Circles() Dim WS As Worksheet, c As Range, MyRng As Range, V As Shape, pdfPath As String Dim x As Integer, r As Integer, lr As Long, wb As Workbook, i As Long, shp As Shape Set WS = Sheets("شهادةنصف") lr = WS.Range("U1").Value: r = 12: x = ActiveWindow.Zoom Application.ScreenUpdating = False: Application.EnableEvents = False: Application.DisplayAlerts = False Set wb = Workbooks.Add(xlWBATWorksheet): WS.Activate: Set MyRng = WS.Range("D13:P13,D30:P30,D47:P47") On Error Resume Next For Each shp In WS.Shapes If shp.AutoShapeType = msoShapeOval Then shp.Delete Next shp On Error GoTo 0 For Each c In MyRng If c.Value <> "" And IsNumeric(WS.Cells(r, c.Column)) And _ Not IsEmpty(WS.Cells(r, c.Column)) And (c.Value < WS.Cells(r, c.Column) Or c.Value = "U" Or _ c.Value = "UU" Or c.Value = "غ") Then Set V = WS.Shapes.AddShape(msoShapeOval, c.Left + 1, c.Top + 1, c.Width - 2, c.Height - 2) V.Fill.Visible = msoFalse: V.Line.ForeColor.SchemeColor = 10: V.Line.Weight = 1.5 End If Next c For i = 1 To lr Step 3 WS.Range("H1").Value = i: WS.Copy After:=wb.Worksheets(wb.Worksheets.Count) Next i wb.Worksheets(1).Delete pdfPath = ThisWorkbook.Path & "\" & "الشهادات" & ".pdf" wb.ExportAsFixedFormat Type:=xlTypePDF, Filename:=pdfPath wb.Close SaveChanges:=False Application.ScreenUpdating = True: Application.EnableEvents = True: Application.DisplayAlerts = True MsgBox "تم تصدير الشهادات إلى PDF" & vbCrLf & "المسار: " & pdfPath, vbInformation, "تم التصدير" End Sub

تم تعديل انظر المرفق test.xlsb

وعليكم السلام ورحمة الله تعالى وبركاته Option Explicit Private Sub Worksheet_SelectionChange(ByVal Target As Range) Dim a() As Variant, ColArr As Variant, CelArr As Variant, txt As String, i As Integer, OnRng As Range Dim WS As Worksheet: Set WS = Sheets("النموذج النهائي") Set OnRng = Me.Range("A" & Target.Row & ":AC" & Target.Row) txt = "مؤقت لمدة" If Not Intersect(Target, Me.Range("AD:AD")) Is Nothing And Me.Cells(Target.Row, "AD").Value <> "" Then If InStr(Me.Cells(Target.Row, "AD").Value, "ترحيل") > 0 Then If Application.CountA(OnRng) = 0 Then: MsgBox "لا يوجد بيانات في الصف ", vbExclamation: Exit Sub ColArr = Array("i", "G", "d", "C", "O", "U", "F", "Z") CelArr = Array("L2", "C9", "E13", "G13", "C14", "C15", "C16", "J26") ReDim a(LBound(ColArr) To UBound(ColArr)) For i = LBound(ColArr) To UBound(ColArr): a(i) = Me.Cells(Target.Row, ColArr(i)).Value: Next i WS.[C21].Value = IIf(Me.Cells(Target.Row, "Q").Value <> "", txt & " (" & Me.Cells(Target.Row, "Q").Value & ") سنوات", "") WS.[C22].Value = IIf(IsDate(Me.Cells(Target.Row, "R").Value), Format(Me.Cells(Target.Row, "R").Value, "yyyy/mm/dd"), "") WS.[C23].Value = IIf(IsDate(Me.Cells(Target.Row, "S").Value), Format(Me.Cells(Target.Row, "S").Value, "yyyy/mm/dd"), "") Application.ScreenUpdating = False : Application.EnableEvents = False On Error GoTo SubApp For i = LBound(CelArr) To UBound(CelArr): WS.Range(CelArr(i)).Value = a(i): Next i SubApp: Application.ScreenUpdating = True: Application.EnableEvents = True End If End If End Sub طلب ترحيل.xls

وعليكم السلام ورحمة الله وبركاته عند النحاق طلبة جدد اضغطي على زر نجميع البيانات فيتم تحديث البيانات الكود Sub CombineSheets() Dim ws As Worksheet Dim mainSheet As Worksheet Dim dataRange As Range Dim cell As Range Dim lastRow As Long Dim newRow As Long Dim i As Long Dim rowsArray() As Variant Set mainSheet = ThisWorkbook.Worksheets(1) mainSheet.Range("A3:FQ" & mainSheet.Cells(mainSheet.Rows.Count, "A").End(xlUp).Row).ClearContents newRow = 3 Application.ScreenUpdating = False Application.Calculation = xlCalculationManual For Each ws In ThisWorkbook.Worksheets If ws.Index <> 1 Then Set dataRange = ws.Range("A3:FQ" & ws.Cells(ws.Rows.Count, "A").End(xlUp).Row) rowsArray = dataRange.Value For i = 1 To UBound(rowsArray, 1) lastRow = mainSheet.Cells(mainSheet.Rows.Count, "A").End(xlUp).Row + 1 mainSheet.Cells(lastRow, 1).Resize(1, UBound(rowsArray, 2)).Value = Application.WorksheetFunction.Index(rowsArray, i, 0) Next i End If Next ws Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic End Sub

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

شيء آخر مهم يجب التأكد منه وهو حقل Person ID في اكسل هذا هو المعرف للموظف .. يجب ان يكون هذا المعرف معتمدا للموظفين في اكسس اي موجود في جدول الاسماء

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

على اعتبار انك زبون تفضل اوفسنا كود ايقاف3.rar

شايب محترف جدا 😅💪 ... أصلا الحياة حلوة 😁✌ أكثر الأنظمة تعقيدا وتخترق .. فما بالك بتجارب هاوي 🙈

كلامك سليم 100% ، ولكن الهدف في عدم اغلاق قاعدة البيانات هي تجربة الفكرة .

مشاركة مع الأساتذة ، في حدث بعد التحديث لمربع النص middledot ، استخدم الكود التالي وهو تلقائياً سيقوم باضافة "." بعد التحديث بعد 3 حروف ، او تغيير القيمة حسب حاجتك :- Private Sub middledot_AfterUpdate() Dim txt As String txt = Nz(Me.middledot.Value, "") If Len(txt) = 0 Then Exit Sub txt = Replace(txt, ".", "") If Len(txt) > 3 Then Me.middledot.Value = Left(txt, 3) & "." & Mid(txt, 4) End If Exit Sub End Sub أما عند نسخك سجلات أكثر من 1 على سبيل المثال ، فهذا الاكود في حدث عند التحميل سيقوم بإضاة "." للقيم في الحقل نفسه التي لا تحتوي على "." أساساً . Private Sub Form_Load() Dim db As DAO.Database Set db = CurrentDb() db.Execute "UPDATE Dot " & _ "SET middledot = Left(Replace(middledot,'.',''), 3) & '.' & " & _ "Mid(Replace(middledot,'.',''), 4) " & _ "WHERE middledot IS NOT NULL " & _ "AND Len(middledot) > 3 " & _ "AND Mid(middledot, 4, 1) <> '.'", dbFailOnError Set db = Nothing Exit Sub End Sub وها يضمن عدم اضافة "." للسجلات التي تحتوي أساساً على "." بعد الحرف الثالث .. dot.accdb

تفضل انظر استعلام و نموذج الجديدين dot.accdb

تفضل شغل الاستعلام وهو يقوم بالمهمة تنبيه : لا تكرر تشغيل الاستعلام .. لانه سيضيف نقطة اخرى التشغيل مرة واحدة ثم احذف الاستعلام dot2.rar

ما تزعقش ياخوي يا عبداللطيف 😫 تفضل جرب ادخل اكثر من 3 سجلات وشوف النتيجة بعد ادخالك 4 سجلات اغلق النموذج ثم افتحه من جديد الافضل كتجربة : كل سجل تدخله اغلق النموذج ثم افنح من جديد حتى تصل الى السجل الرابع .. كي تتأكد من جودة الحماية ممنوع دخول الخبراء .. اوفسنا كود ايقاف2.rar

بارك الله فيك/ ابو عارف وجعله الله في ميزان حسناتك

اخواني الاعزاء اريد طريقة سهلة مثل IF STATMANT والاكواد نضع لها رقم سري لكي لا يتم حذف الامر هنا خطر ببالي سؤال اذا تم نسخ قاعدة البيانات الى قاعدة جديدة هل يتم فتحها بسهولة والصول الى الاكواد ؟

تفضل الملف بعد التعديل. تم استخدام المعادلة =COUNTIFS(C5:C32;"";D5:D32;"";E5:E32;"<>") المصنف2.xlsx

😅 هو انتوا لسه شفتوا حاجة 🤗

تفضل استاذ @فؤاد الدلوي المرفق بعد التعديل بطلبك . ووافني بالرد . المدفوعات (3).rar