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

وعليكم السلام ورحمة الله تعالى وبركاته رغم انني أعتقد أنك يجب عليك اتخاد مزيدا من الاجراءات لحماية الملف لاكن سأحاول في الكود التالي تنفيد طلبك إعتمادا على تخزين وقت الدخول الخاطئ في ورقة مخفية تمت إظافتها للملف بإسم Sheet1 يمكنك تعديلها بما يناسبك (يمكنك نخزينه في اي ورقة موجودة مسبقا على المصنف) فرغ نمودج المستخدم الخاص بك من جميع الأكواد السابقة وقم بنسخ هدا Private Sub CommandButton1_Click() Dim WS As Worksheet Dim Utilisateu As String, Passe As String Dim key As Date Static Compter As Integer Set WS = ThisWorkbook.Sheets("Sheet1") key = WS.[A1] '**** تم تحديد قفل الملف 30 ثانية للتجربة**** Clé = Now + TimeValue("00:00:30") '******************************************** 'Clé = Now + TimeValue("00:30:00") ' تحديد وقت القفل بعد 30 دقيقة WS.Visible = xlSheetVeryHidden Utilisateu = TextBox1.Value 'اسم المستخدم Passe = TextBox2.Value ' الرقم السري ' تغيير لون خلفية مربع كلمة المرور عند الإدخال الخاطئ TextBox2.BackColor = RGB(255, 255, 255) ' اللون الافتراضي If key > Now Then MsgBox "الملف مغلق يرجى المحاولة مرة أخرى بعد " & _ Format(key - Now, "hh:mm:ss") & ".", vbExclamation, "تعذر الدخول للملف" ThisWorkbook.Save ThisWorkbook.Close False Exit Sub End If If Utilisateu = "admin" And Passe = "1234" Then Compter = 0 MsgBox Utilisateu & " مرحبًــا بك", vbInformation, "ترحيب" Application.Visible = True Unload Me Else Compter = Compter + 1 TextBox2.BackColor = RGB(255, 0, 0) ' تغيير اللون إلى الأحمر عند الإدخال الخاطئ If Compter >= 3 Then ' تحديد عدد المحاولات المسموح بها key = Clé: WS.[A1] = key MsgBox "تم قفل الملف لمدة 30 دقيقة", vbCritical, "تعذر الدخول للملف" Compter = 0 ThisWorkbook.Save ThisWorkbook.Close False Exit Sub Else MsgBox "بيانات الدخول غير صحيحة. محاولة " & _ Compter & " من 3", vbExclamation, "إنتباه" End If End If End Sub وفي حدث ThisWorkbook Private Sub Workbook_Open() Dim kay As Date On Error Resume Next kay = Sheets("Sheet1").Range("A1").Value On Error GoTo 0 If kay > Now Then MsgBox "الملف مغلق يرجى المحاولة مرة أخرى بعد " & _ Format(kay - Now, "hh:mm:ss") & ".", vbExclamation, "تعذر الدخول للملف" ThisWorkbook.Save ThisWorkbook.Close False Else Application.Visible = False UserForm1.Show End If End Sub بالتوفيق.. دخول بعد ساعة.xlsm

تفضل 🙂 New Microsoft Access Database (1).accdb

وعليكم السلام ورحمة الله تعالى وبركاته جرب هل هدا ما تقصده Sub SansDoublons() Dim dict As Object, tmp As Variant Dim cell As Range, i As Long Dim f As Worksheet: Set f = Sheets("Sheet1") Dim WS As Worksheet: Set WS = Sheets("Sheet2") Application.ScreenUpdating = False Set dict = CreateObject("Scripting.Dictionary") For Each cell In f.Range("b5:b100") If Len(cell.Value) > 0 And Not dict.exists(cell.Value) Then dict.Add cell.Value, Nothing End If Next cell If dict.Count > 0 Then WS.Range("b5:b100").ClearContents tmp = dict.Keys For i = LBound(tmp) To UBound(tmp) WS.Cells(i + 5, 2).Value = tmp(i) Next i End If Application.ScreenUpdating = True End Sub لتشغيل الماكرو تلقائيا عند الغيير في عمود (b) ورقة 1 في حدث Sheet1 Private Sub Worksheet_Change(ByVal Target As Range) If Not Intersect(Target, Me.Range("b5:b100")) Is Nothing Then SansDoublons End If End Sub نقل القيم بدون تكرار.xlsb

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

ادن جرب هدا ربما يفيدك Sub Locked(ByVal bEnabled As Boolean) Dim sh As Worksheet, tmp As Integer, Cnt As Integer Set WS = Sheets("واجهة البرنامج") If bEnabled = True Then Cnt = -1 '<<==== Visible tmp = 2 '<<==== Hidden Else Cnt = 2 tmp = -1 End If With ThisWorkbook On Error Resume Next Application.ScreenUpdating = False WS.Visible = Cnt For Each sh In .Sheets If Not sh.Name = WS.Name Then sh.Visible = tmp End If Next sh WS.Visible = Cnt Application.ScreenUpdating = True On Error GoTo 0 End With End Sub Sub Verification() With ThisWorkbook Application.DisplayAlerts = False If .Path <> vbNullString Then .ChangeFileAccess xlReadOnly ' Kill .FullName '<<==== لحدف المصنف نهائيا End If .Close SaveChanges:=False End With End Sub Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean) Locked True ActiveWorkbook.Protect Structure:=True, Windows:=False, Password:="1234" End Sub Private Sub Workbook_Open() Select Case Environ("COMPUTERNAME") Case "HP ZBook Power", "Your device name" ' '<<==== أسماء أجهزة الكمبيوتر المعتمدة Locked False ActiveWorkbook.Unprotect "1234" Case Else Verification End Select End Sub Password 1234 فتح المصنف على اجهزة محددة.xlsm

يمكنك جلب اخر قيمة على الليست بوكس باستبدال هده السطور tb = sum1 - sum2 TextBox1.Value = Format(tb, "#,##00.00") وجعلها هكدا With Application sum3 = .Max(.Index(Me.ListBox1.List, r, 9)) ' الرصيد الختامى End With TextBox1.Value = Format(sum3, "#,##00.00") Copy of كشف حساب عميل -V4.xlsm

إن شاء الله يفيدك هذا الملف نموذج بسيط لاختيار الوقت مثل اختيار التاريخ بالتوفيق time picker.xlsb

Set Sp = CreateObject("sapi.spvoice") 👍