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

السلام عليكم دالة countif مضافاً إليها دالة max ضعها في a2 ثم اسحبها للاسفل =IF(COUNTIF($B$2:B2; B2)=1; MAX($A$1:A1)+1; "") ملف ترقيم بتجاوز المكرر.xlsx

كتطبيق مباشر لسؤال الأخ @moho58 .. من مكتبتي هذا ملف أجنبي يقوم بالتراجع عن التعديلات في النموذج المستمر في حال لم يتم تأكيد الحفظ 🙂 UsingTransactionNoClass.accdb المصدر (هنا)

السلام عليكم الي جميع المهتمين بالاكسس ، تفضل فيديو كامل لشرح طريقة تسجيل بيانات من الموبيل الي قاعدة بيانات اكسس الشرح خطوة بخطوة مع تحميل التطبيق في هذا الفيديو رابط الفيديو علي اليوتيوب ربط الاكسس بالموبيل بالتوفيق

الدالة لتحويل نتائج دالة التفقيط NoToTxt (لا أعرف كاتبها) إلى أرقام. وقد كتبتها بناءً على طلب أحد أعضاء منتدى الاكسل. Function NoToTxtRev(ByVal TheTxt As String, MyCur As String, MySubCur As String) As Double 'AbuuAhmed, last update 2024/12/30 'Reverse of NoToTxt function Dim Pos As Integer, Step As Byte, Part4 As Integer, Part As Byte Dim i As Byte, ii As Integer Dim Parts(6), a, b, c Dim Text As String Dim Sum4 As Double, Sum As Double Dim Key0, Key1, Key2, Key3 Dim Sp As Integer Dim Pwr As Integer a = Array("", "مائة", "مائتان", "ثلاثمائة", "أربعمائة", "خمسمائة", "ستمائة", "سبعمائة", "ثمانمائة", "تسعمائة", _ "", "عشر", "عشرون", "ثلاثون", "أربعون", "خمسون", "ستون", "سبعون", "ثمانون", "تسعون", _ "", "واحد", "اثنان", "ثلاثة", "أربعة", "خمسة", "ستة", "سبعة", "ثمانية", "تسعة") b = Array("إحدى", "إثنى", "عشرة", "فقط ", "و ", "ملياران", "مليونان", "ألفان", _ "ومليار", "ومليون", "وألف", "فقط مليار", "فقط مليون", "فقط ألف", "فقط ") c = Array("واحد", "اثنان", "صفر عشر", "فقط ", "و", "اثنان مليار", "اثنان مليون", "اثنان ألف", _ "وواحد مليار", "وواحد مليون", "وواحد ألف", "واحد مليار", "واحد مليون", "واحد ألف", "") Key1 = Array("", "مليار", "ملياران", "مليارات") Key2 = Array("", "مليون", "مليونان", "ملايين") Key3 = Array("", "ألف", "ألفان", "آلاف") For i = 0 To UBound(b) TheTxt = Replace(TheTxt, b(i), c(i)) Next i If MyCur & MySubCur <> "" Then Pos = InStr(1, TheTxt, MyCur) If Pos > 0 Then Parts(5) = Replace(Mid(TheTxt, Pos + Len(MyCur)), MySubCur, "") TheTxt = Left(TheTxt, Pos - 1) Else Pos = InStr(1, TheTxt, MySubCur) If Pos > 0 Then Parts(5) = Replace(TheTxt, MySubCur, "") TheTxt = "" End If End If Else Pos = InStr(1, TheTxt, " ") If Pos > 0 Then Parts(5) = Trim(Mid(TheTxt, Pos + 3)) TheTxt = Left(TheTxt, Pos - 1) End If End If For Part = 1 To 3 Key0 = IIf(Part = 1, Key1, IIf(Part = 2, Key2, Key3)) Pos = InStr(1, TheTxt, Key0(1)) If Pos = 0 Then Pos = InStr(1, TheTxt, Key0(2)) If Pos = 0 Then Pos = InStr(1, TheTxt, Key0(3)) If Pos > 0 Then Parts(Part) = Left(TheTxt, Pos - 1) Pos = InStr(Pos, TheTxt & " ", " ") TheTxt = Mid(TheTxt, Pos) End If Next Part Parts(4) = TheTxt For i = 1 To 5 Parts(i) = Trim(Replace(Parts(i), " و", " ")) Parts(i) = Replace(Parts(i), " احد", " واحد") Next i For Part4 = 0 To 12 Step 3 Part = Part4 / 3 + 1 Sum4 = 0 Sp = 3 - (Len(Parts(Part)) - Len(Replace(Parts(Part), " ", ""))) If Sp < 1 Then Sp = 1 For Step = Sp To 3 Pos = InStr(1, Parts(Part) & " ", " ") Text = Trim(Left(Parts(Part), Pos - 1)) Parts(Part) = Mid(Parts(Part), Pos + 1) If Text <> "" Then For i = 1 To UBound(a) Pwr = 10 ^ (3 - Fix((i - 1) / 10) - 1) ii = i Mod 10 If Text = a(i) Then If Part = 5 Then Sum4 = Sum4 + ii * Pwr Else Sum4 = Sum4 + ii * Pwr * Val("1" & IIf(Part = 5, "", String(9 - Part4, "0"))) End If Exit For End If Next i End If Next Step Sum = Sum + IIf(Part = 5, Sum4 / 100, Sum4) Next Part4 NoToTxtRev = Sum End Function

تفضل أخي @moho58 طلبك بالمرفق . BASEM-2.rar

مشاركة مع استاذي @Eng.Qassim اليك استاذ @moho58 محاولتي حسب مافهمت . ووافني بالرد . BASEM-1.rar

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

وعليكم السلام ورحمة الله تعالى وبركاته حل اخر بإستخدام الأكواد Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) Dim lastRow As Long, i As Long, n As Long, tmp As Variant, a As Object If Intersect(Target, Me.Columns("A:B")) Is Nothing Then Exit Sub Application.EnableEvents = False Application.ScreenUpdating = False On Error Resume Next lastRow = Me.Columns("A:B").Find(What:="*", _ SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row On Error GoTo 0 If lastRow < 2 Then GoTo CleanUp Me.Range("A2:A" & lastRow).ClearContents tmp = Me.Range("B2:B" & lastRow).Value: Set a = CreateObject("Scripting.Dictionary") For i = 1 To UBound(tmp) If Len(Trim(tmp(i, 1))) > 0 And Not a.exists(tmp(i, 1)) Then n = n + 1: a(tmp(i, 1)) = n: Me.Cells(i + 1, "A").Value = n End If Next i CleanUp: Application.ScreenUpdating = True Application.EnableEvents = True End Sub ترقيم بتجاوز المكرر.xlsb

جرب، المثال في الاستعلام myFormat_01.accdb

أشكرك أستاذ جمال على مرورك لمن لا يعلم ، الأستاذ جمال هو المستشار القانونى للرد على أسئلة أعضاء منتديات داماس القديم بارك الله فى عمرك أخى الفاضل

حياك الله أخي @Foksh وشكرا على المشاركة، الدالة لتحويل نتائج دالة التفقيط NoToTxt فقط بمحاسنها ومساوئها ونطاقها، الدالة موجودة في ملف الإكسل ضمن مشاركة منتدى الإكسل، الملف به أمثلة كذلك، يستحسن الاطلاع عليه.

هذه تساعدك على الترتيب تصاعديا وتنازليا بشكل صحيح = "D:\الهويات\Pictures\" & TEXT(ROW(),"00000") & ".jpg"

وعليكم السلام ورحمة الله وبركاته ="D:\الهويات\Pictures\" & ROW(A1) & ".jpg" ثم لسحب للاسفل ويمكنك نسخها ولصقها كقيم يعد ذلك New Microsoft Excel Worksheet.xlsx

كان من المفترض تجهيز الملف بحيث الاسماء لا تتكرر في الفروع الثلاتة ولا رقم الموظف وان فرضنا ان الموظف يعمل في اكثر من فرع فاليوم ووقت العمل يفترض ان يكون مختلف في شيت Employee لاحظت بداية الوقت 8 صباحا ونهاية الوقت 6 صباحا بمعنى العمل 22 ساعة هل هذا صحيح ام ان البيانات عشوائية على العموم جرب الملف وضع فيه بيانات واقعية وقم بتجربته باقى المطالب بعد التأكد مراجعنك للملف وابداء اي ملاحظات attedance report (1).xlsb

أظن أنه يمكننا إضافة شرط التحقق من كلمة المرور عند محاولة غلق الحسابات في الكود بحيث لا يمكن لأي شخص تنفيذه إلا إذا كان يعرف كلمة المرور الصحيحة هذا يضيف طبقة أمان إضافية للحماية ويضمن أن الشخص الذي يقوم بالعملية هو الشخص المخول فقط جرب هدا التعديل Option Explicit Private Const Clé As String = "1234" Public Property Get WS() As Worksheet Set WS = Sheets("Sheet1") End Property Sub ProtectSheet(xligne As Long) With WS .Unprotect Password:=Clé: .Cells.Locked = False .Range("A2:M" & xligne).FormulaHidden = True .Range("A2:M" & xligne).Locked = True: .Protect Password:=Clé End With End Sub Sub WSUnprotect() With WS .Unprotect Password:=Clé .Cells.Locked = False .Cells.FormulaHidden = False End With End Sub Sub Data_Protection() Dim xligne As Long If InputBox("أدخل كلمة المرور للمتابعة") <> Clé Then MsgBox "كلمة المرور غير صحيحة تم إلغاء العملية", vbCritical Exit Sub End If xligne = Application.InputBox("أدخل رقم الصف الأخير لقفل الخلايا", Type:=1) If xligne < 1 Or xligne > WS.Rows.Count Then MsgBox "خطأ في الإدخال يرجى إدخال رقم صف صحيح", vbExclamation Exit Sub End If SetApp False ProtectSheet xligne SetApp True MsgBox "تم قفل الحسابات بنجاح لغاية الصف: " & xligne, vbInformation End Sub Sub Data_UnProtection() Dim PassProtect As String PassProtect = InputBox("أدخل كلمة المرور لفك الحماية") If PassProtect = Clé Then SetApp False: WSUnprotect: SetApp True MsgBox "تم فتح جميع الحسابات بنجاح", vbInformation ElseIf PassProtect <> "" Then MsgBox "كلمة المرور غير صحيحة", vbCritical End If End Sub Private Sub SetApp(ByVal enable As Boolean) On Error GoTo xError Application.ScreenUpdating = enable Application.EnableEvents = enable Application.Calculation = IIf(enable, xlCalculationAutomatic, xlCalculationManual) Exit Sub xError: End Sub غلق المدى المحدد .xlsb

سبقني الأستاذ محمد هشام ولكني للتو رأيت مشاركته. PeriodsDiff_02.xlsx

وعليكم السلام ورحمة الله تعالى وبركاته جرب هدا Book1.xlsx