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

إثراءا للموضوع يمكنك توسيع منع التكرار على عدة أعمدة مثلا A - C - E Private Sub Worksheet_Change(ByVal Target As Range) Dim i As Long, OnRng As Range, Cell As Range Dim ColArr As Variant, tmp As Long On Error GoTo CleanExit Application.EnableEvents = False ColArr = Array("A", "C", "E") ' ColArr = Array("A") For i = LBound(ColArr) To UBound(ColArr) If Not Intersect(Target, Me.Range(ColArr(i) & "2:" & ColArr(i) & Me.Rows.Count)) Is Nothing Then Set OnRng = Me.Columns(ColArr(i)) For Each Cell In Intersect(Target, OnRng) If Trim(Cell.Value) <> "" Then tmp = Application.WorksheetFunction.CountIf(OnRng, Cell.Value) If tmp > 1 Then Cell.ClearContents End If End If Next Cell End If Next i CleanExit: Application.EnableEvents = True End Sub

وعليكم السلام ورحمة الله تعالى وبركاته جرب الملف يتم الحدف عند الادخال او عند اللصق Private Sub Worksheet_Change(ByVal Target As Range) Dim rngChanged As Range Dim cell As Range Dim dict As Object Dim lastRow As Long Dim ws As Worksheet Set ws = Me lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row Set rngChanged = Intersect(Target, ws.Range("A1:A" & lastRow)) If rngChanged Is Nothing Then Exit Sub Application.EnableEvents = False Application.ScreenUpdating = False Set dict = CreateObject("Scripting.Dictionary") For Each cell In ws.Range("A1:A" & lastRow) If Not Intersect(cell, rngChanged) Is Nothing Then GoTo NextCell If Not IsEmpty(cell.Value) Then dict.Add CStr(cell.Value), 1 End If NextCell: Next cell For Each cell In rngChanged If Not IsEmpty(cell.Value) Then If dict.exists(CStr(cell.Value)) Then Application.Undo ' MsgBox "القيمة '" & cell.Value & "' موجودة مسبقاً!", vbExclamation, "تنبيه" Exit For Else dict.Add CStr(cell.Value), 1 End If End If Next cell Application.EnableEvents = True Application.ScreenUpdating = True End Sub no duplicate.xlsb

وعليكم السلام ورحمة الله تعالى وبركاته هل ترغب بإستخدام الأكواد ؟ ادا كان هدا يناسبك ضع هدا في حدث الورقة Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) Dim Cell As Range, tmp As Long On Error GoTo CleanExit Application.EnableEvents = False If Not Intersect(Target, Me.Range("A2:A" & Me.Rows.Count)) Is Nothing Then For Each Cell In Intersect(Target, Me.Range("A2:A" & Me.Rows.Count)) If Trim(Cell.Value) <> "" Then tmp = Application.WorksheetFunction.CountIf(Me.Range("A:A"), Cell.Value) If tmp > 1 Then Cell.ClearContents End If End If Next Cell End If CleanExit: Application.EnableEvents = True End Sub

وعليكم السلام ورحمة الله وبركاته .. حاولت فهم الموضوع من معطياتك أخي الكريم ولكني لم أوفق .. ان أمكن توضيح أكثر فنكون من الشاكرين

وعليكم السلام ورحمة الله وبركاته Private Sub Worksheet_Change(ByVal Target As Range) Dim rg As Range, cell As Range Set rg = Intersect(Target, Columns("A")) If rg Is Nothing Then Exit Sub Application.EnableEvents = False On Error GoTo CleanUp For Each cell In rg If Not IsEmpty(cell.Value) Then If Not cell.Value Like "???-###-####" Or _ IsNumeric(Left(cell.Value, 3)) Or _ Not IsNumeric(Mid(cell.Value, 5, 3)) Or _ Not IsNumeric(Mid(cell.Value, 9, 4)) Then MsgBox "الرجاء إدخال القيمة بالتنسيق الصحيح: 3 حروف-3 ارقام-4 ارقام", vbExclamation cell.ClearContents End If End If Next cell CleanUp: Application.EnableEvents = True End Sub aaa-123-4345.xlsb

Select column A for example then from Data tab select Data Validation Select Custom and paste the formula This is the formula you can use =AND(ISNUMBER(VALUE(MID(A1,5,3))), ISNUMBER(VALUE(MID(A1,9,4))), ISERROR(VALUE(LEFT(A1,3))), MID(A1,4,1)="-", MID(A1,8,1)="-", LEN(A1)=12)

وجدت تغيرات طفيفة في التعديل الاخير مكعوسة وتمت معالجة المشكلة توفي الزوج بعد تاريخ طلاق الزوجة Me.k7.Visible = False Me.Da7.Visible = True Me.Za7.Visible = True Else Me.k7.Visible = True Me.Da7.Visible = False Me.Za7.Visible = False والحمد لله اما بخصوص تنسيق التاريخ تم ايجاد حل عموما شكرا لك استاذي الكريم وربي يحفظك ومايحرمنا من تواجدك معنا ومد يد المساعدة لاخوانك الله يجعلها في ميزان حسناتك ان شاء الله

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

سؤال جميل جداً .. برأيي هل من الممكن أن يكون السبب لتحديد الخصم للصنف / أصناف محددة وليس للفاتورة بشكل عام !! فقد تتيح له فرصة الخصم على اصناف محدة وليس جميع الاصناف ، أو الإستفادة من فكرة العروض على الأصناف ( إن لم يخني التعبير )

لا تستعجل على رزقك انا شرطت الانتقال الى الدفع بعد استيعاب وفهم العمل الحالي انت لم تدرس المثال جيدا .. كطالب علم يجب ان تسأل عن الصغيرة قبل الكبيرة مثلا لماذا اكتفينا بوضع الخصم (واحتسابه) في جدول الاصناف فقط ولم ندرجه في التفاصيل هذه المعلومة جديدة حتى على هذا المنتدى يوجد ملاحظات اخرى يجب ان لا تمر عليك مرور الكرام .. حتى تفهمها : كيف ولماذا ؟ ملحوظة : اسماء الجداول يجب ان تبدأ بالبادئة tbl والنماذج بالبادئة frm والاستعلامات بالبادئة qry والتقارير بالبادئة rep

أخي @طاهر اوفيسنا ، توضيحك للقيم الخاصة بالهامش في الجداول جاءت لك بفائدة كبيرة وهذا الى حد ما جزء من التأسيس الصحيح . تم استخدام هياكل تحكم أفضل من الجمل الشرطية . حيث استبدلت عبارات If-ElseIf المتعددة ببنية Select Case أكثر وضوحاً واستقرار مع دالة مساعدة بسيطة ، في المرفق التالي :- فتح تقرير FACE15.zip وفي الواقع انا تلافيت التعديل والعبث في مكونات جداولك بعد تعليقك على تعديلاتي في التقرير 😅 . ردك جعلني أتراجع عن المتابعة الى حد ما سابقاً ولكن الحمد لله تيسرت بطريقتك المشروعة .

استاذي العزيز فما محاولة لي بدالة IF تفي بالغرض المطلوب ياريت تتطلع عليها واذا رأيت اختصارات فقم باللازم فتح تقرير FACE15.rar

عدلت على النماذج انظر النماذج الخدمية كيف اصبحت خاصة نموذج الأصناف وانظر سعر البيع والخصم والسعر النهائي ( غالبا الخصم على البيع لم يمر بي خصم على المشتريات انما البائع هو من يضع الخصم على السلعة المباعة ) ....................................... عملك فقط على فورم الفاتورة .. تم تحسين الفاتورة والتفاصيل - جعلت خاصية حقول نوع العملية .. ونوع الدفع (مطلوبة=نعم) عمليات التفاصيل في النموذج الفرعي تعتمد على حقل نوع العملية في فورم الفاتورة الرئيسي - ادخال الصنف اما بالرقم او الاختيار - عند كتابة رقم الصنف او اختياره من مربع التحرير .. يتم ادراج السعر ( شراء او بيع ) - عند كتابة الكمية يظهر الاجمالي في الحقل المخصص ( شراء او بيع ) اللمسات والتحسينات ممكنة مثل ضم حقلي الاجمالي فوق بعض بحيث لا يظهر الا الحقل الموافق لنوع العملية ومثل رسائل النظام واستبدالها برسائل مفهومة ................... ومثل ان نعمل رأسين للفاتورة واحد للبيع وأخر للمشتريات .. بدلا من اختيار النوع في كل عملية .. وتسهيلا للمستخدم ويمكن عمل اربع رؤوس لا تستغرب اثنان للبيع النقد والآجل واثنان للشراء النقد والآجل كل هذه الأربعة تصب في جدول واحد .............. وتحسينات اخرى كثيرة يمكن مستقبلا عملها المهم عملية البيع والشراء الأساسية تسير بشكل محكم وسلس _____________________________________ جرب كل الانواع وحاول تدرس المثال والاكواد الخاصة .. مهم جدا تفهم الاكواد في النموذج الفرعي وتعرف كيف تتم العملية وخطواتها معرفة تامة خذ وقتك ولا تستعجل .. الدرس هذا بسيط وهو البداية ملحوظة : مرتجع الشراء هو عبارة عن بيع ومرتجع البيع عبارة عن شراء ........... بعد ذلك يمكننا الانتقال الى عملية الدفع Invoices2.rar

وعليكم السلام ورحمة الله وبركاته أهلا بك.. الطريقة التالية تقوم أولا بالتحقق من مسار الملف ، ثم التحقق من وجود الملف. وذلك عن طريق حدث السجل الحالي Private Sub Form_Current() '--تحقق مسار الملف مكان_الملف = "D:\FILE\" مسار_الملف = IIf(Len(Dir(مكان_الملف)), مكان_الملف, CurrentProject.Path & "\") & Me.رقم_الموضف & ".PDF" '-- تحقق من وجود الملف Me.لديه_ملف = IIf(Len(Dir(مسار_الملف)), "نعم", "لا") End Sub FILE.zip

وعليكم السلام ورحمة الله وبركاته ،، أخي الكريم يوجد أكثر من طريقة واسلوب وحل ، ولكن قبل الشروع بذكر أحدها سأنصحك نصيحة متفرعة = 1. الإبتعاد عن التسميات العربية للجداول والحقول والنماذج ومكوناتها . 2. عدم استخدام "-" في التسميات ، والأفضل استخدام "_" إن كنت مضطراً . الآن في النموذج سنقوم بحذف جميع الأكواد ولا حاجة لها ولا حاجة للزر أيضاً ، ثم في مديول جديد ألصق الكود التالي :- Public Sub UpdateEmployeeFiles() Dim db As DAO.Database Dim rs As DAO.Recordset Dim strPath As String Dim strFileName As String strPath = CurrentProject.Path & "\" Set db = CurrentDb Set rs = db.OpenRecordset("جدول1", dbOpenDynaset) If Not rs.EOF Then rs.MoveFirst Do Until rs.EOF strFileName = strPath & rs!رقم_الموضف & ".pdf" rs.Edit If Dir(strFileName) <> "" Then rs!لديه_ملف = "نعم" rs!مسار_الملف = strFileName Else rs!لديه_ملف = "لا" rs!مسار_الملف = Null End If rs.Update rs.MoveNext Loop End If rs.Close Set rs = Nothing Set db = Nothing End Sub وفي النموذج يكفينا الإستدعاء للدالة في حدث عند التحميل كما يلي :- Private Sub Form_Load() UpdateEmployeeFiles End Sub حيث أن الدالة ستقوم بتحديث قيمة الحقل في كل مرة تفتح فيها النموذج للموظفين الذين لديهم ملف PDF أو لا . أيضاً سيتم تعديل مسار الملف اذا كان موجوداً بدلاً من استخدامك للكود السابق في حدث "في الحالي" . FILE.zip

مساهمة بعد تعديلها لتعمل على اكسل بدلاً من اكسيس ولست متأكد منها :- في وحدة نمطية جديدة = Option Compare Database #If VBA7 Then Private Declare PtrSafe Function OpenProcessToken Lib "advapi32.dll" ( _ ByVal ProcessHandle As LongPtr, _ ByVal DesiredAccess As Long, _ ByRef TokenHandle As LongPtr _ ) As Long Private Declare PtrSafe Function GetTokenInformation Lib "advapi32.dll" ( _ ByVal TokenHandle As LongPtr, _ ByVal TokenInformationClass As Long, _ ByRef TokenInformation As Any, _ ByVal TokenInformationLength As Long, _ ByRef ReturnLength As Long _ ) As Long Private Declare PtrSafe Function GetCurrentProcess Lib "kernel32" () As LongPtr Private Declare PtrSafe Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" ( _ ByVal hwnd As LongPtr, _ ByVal lpOperation As String, _ ByVal lpFile As String, _ ByVal lpParameters As String, _ ByVal lpDirectory As String, _ ByVal nShowCmd As Long _ ) As LongPtr #Else Private Declare Function OpenProcessToken Lib "advapi32.dll" ( _ ByVal ProcessHandle As Long, _ ByVal DesiredAccess As Long, _ ByRef TokenHandle As Long _ ) As Long Private Declare Function GetTokenInformation Lib "advapi32.dll" ( _ ByVal TokenHandle As Long, _ ByVal TokenInformationClass As Long, _ ByRef TokenInformation As Any, _ ByVal TokenInformationLength As Long, _ ByRef ReturnLength As Long _ ) As Long Private Declare Function GetCurrentProcess Lib "kernel32" () As Long Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" ( _ ByVal hwnd As Long, _ ByVal lpOperation As String, _ ByVal lpFile As String, _ ByVal lpParameters As String, _ ByVal lpDirectory As String, _ ByVal nShowCmd As Long _ ) As Long #End If Public Function IsRunAsAdmin() As Boolean Const TOKEN_QUERY As Long = &H8 Const TokenElevation As Long = 20 Dim hToken As LongPtr Dim elev As Long Dim retLen As Long If OpenProcessToken(GetCurrentProcess(), TOKEN_QUERY, hToken) <> 0 Then If GetTokenInformation(hToken, TokenElevation, elev, LenB(elev), retLen) <> 0 Then IsRunAsAdmin = (elev <> 0) End If End If End Function Public Sub RestartAsAdmin() Dim exePath As String Dim dbArgument As String exePath = Application.FullName dbArgument = """" & Application.CurrentProject.FullName & """" ShellExecute 0, "runas", exePath, dbArgument, vbNullString, 1 Application.Quit End Sub Public Sub CreateTextFile() Dim FilePath As String Dim FileNum As Integer If Not IsRunAsAdmin Then MsgBox "البرنامج بحاجة إلى صلاحيات مسؤول (Administrator)." & vbCrLf & _ "سيتم إعادة تشغيل Access بطلب صلاحيات مرتفعة...", _ vbExclamation, "تحتاج صلاحيات" RestartAsAdmin Exit Sub End If FilePath = "C:\Windows\fs.txt" FileNum = FreeFile Open FilePath For Output As #FileNum Print #FileNum, "fs" Close #FileNum MsgBox "تم إنشاء الملف بنجاح في:" & vbCrLf & FilePath, _ vbInformation, "نجاح" End Sub الإستدعاء سيكون في الزر على سبيل المثال = CreateTextFile

جزاك الله خيرا استاذ/ عبد الله على الاقتراح الجميل تم عمل اللازم في ملفين. الملف الأول بالمعادلات و لكنه يتطلب اصدار حديث مثل 356 أو 2021 أما الملف الثاني فتم عمله بالأكواد لاستخراج القيم الأعلى المتماثلة لمن ليس عنده الاصدرات الحديثة Book6.xlsx Book6.xlsm

رائع كود الاستاذ/ عبدالله حل آخر بالمعادلات و التنسيق الشرطي بعيدا عن الأكواد Book5.xlsx

وعليكم السلام ورحمة الله وبركاته حسب قهمي لطلبك اليك الملف في حالة تساوي القيم الاعلى يتم دكرها مع تظليل الصف Book4.xlsb

تعديل بسيط للتحكم في ظهور الأوراق من خلال تعطيل خاصية إظهار و إخفاء. فقط للعلم الملفات التي بها عناصر تحكم لا تعمل أونلاين سواء موقع أوفيس أو جوجل DATA2.xlsb

السلام عليكم ورحمة الله وبركاته لا اعتقد ان طلبك يمكن عمله بالمعادلات ولكن يمكن بالكود اكتب اسم المستخدم وكلمة السر للمدرسة وسيتم اخفاء كل الصفحات ما عدا صفحة المدرسة وصفحة main الزر الاخر لاظهار كل الصفحات فربما تحتاجه اثناء تجهيز ملفك ويمكنك حذفه لاحقا جرب الملف وات كان هناك ملاحظات اذكرها DATA.xlsb

السلام عليكم ورحمة الله وبركاته بعد اذن معلمنا واستاذنا محمد هشام جدول2.xlsm

الفصل الثاني واذكركم بس دا كتاب تم تأليفه بواسطة السيد ذكاء بيه الاصطناعي يعني مش انا وكمان مفيش تنسيق ولا مراجعه بالقدر .. العمر بيفرق والنظر راح وربنا يوفق يارب ch2.docx

تفضل حدول 2.xlsm

و عليكم السلام ورحمة الله و بركاته يمكن استخدام المعادلة التالية =IF(A2="زمنية"; IF(D2<C2; IF(D2>=12; (D2-C2); (D2+12-C2)); IF(AND(C2>=12; D2>=12); (D2-C2); IF(C2>=12; (D2+12-C2); (D2-C2)) ) ) + IF(B2<>OFFSET(B2;1;0); 24*(OFFSET(B2;1;0)-B2); 0); "") معادلة لاحتساب من وقت الخروج والدخول (2).xlsx

من المفروض أولا كما سبق الدكر محاولة إلغاء دمج الخلايا لضمان أن الكود يتعامل مع كل خلية على حدة وحصولك على نتائج صحيحة جرب هدا هل يناسيك Option Explicit Public Sub Add_CheckBoxes() Dim tbl As Long, cb As OLEObject, OnRng As Range, ky As Variant Dim dataArray() As String, Search As String, n As Boolean Dim i As Long, lastRow As Long, col As Long, lastCol As Long Dim kys() As String Dim CrWS As Worksheet: Set CrWS = Sheets("MenuF") Dim dest As Worksheet: Set dest = Sheets("main sheet") Search = Trim(CrWS.Range("B1").Value) If Search = "" Then: MsgBox "يرجى إدخال قيمة البحث", vbExclamation: Exit Sub lastRow = dest.Cells(dest.Rows.Count, "A").End(xlUp).Row n = False For i = 2 To lastRow If Trim(dest.Cells(i, 1).Value) = Search Then tbl = i n = True Exit For End If Next i If Not n Then: MsgBox "قيمة البحث غير موجودة على قاعدة البيانات", vbExclamation: Exit Sub lastCol = dest.Cells(tbl, Columns.Count).End(xlToLeft).Column ReDim dataArray(1 To lastCol - 1) For col = 2 To lastCol dataArray(col - 1) = Trim(dest.Cells(tbl, col).Value) Next col For Each cb In CrWS.OLEObjects If TypeName(cb.Object) = "CheckBox" Then cb.Object.Value = False Next cb For Each OnRng In CrWS.Range("A3:I7") If OnRng.Value <> "" Then kys = Split(Replace(OnRng.Value, "،", ","), ",") For Each ky In kys For i = LBound(dataArray) To UBound(dataArray) If CompareValues(tmp(dataArray(i)), tmp(ky)) Then For Each cb In CrWS.OLEObjects If TypeName(cb.Object) = "CheckBox" Then If cb.TopLeftCell.Address = OnRng.Address Then cb.Object.Value = True Exit For End If End If Next cb End If Next i Next ky End If Next OnRng End Sub Private Function tmp(ByVal txt As String) As String tmp = Replace(Replace(Trim(txt), " ", " "), "ال", "") End Function Private Function CompareValues(val1 As String, val2 As String) As Boolean CompareValues = (InStr(1, val1, val2, vbTextCompare) > 0 Or InStr(1, val2, val1, vbTextCompare) > 0) End Function لتلوين القيم CrWS.Range("A3:I7").Font.Color = vbBlack For Each OnRng In CrWS.Range("A3:I7") If OnRng.Value <> "" Then kys = Split(Replace(OnRng.Value, "?", ","), ",") For Each ky In kys For i = LBound(dataArray) To UBound(dataArray) If CompareValues(tmp(dataArray(i)), tmp(ky)) Then For Each cb In CrWS.OLEObjects If TypeName(cb.Object) = "CheckBox" Then If cb.TopLeftCell.Address = OnRng.Address Then cb.Object.Value = True Exit For End If End If Next cb OnRng.Font.Color = vbRed End If Next i Next ky يمكنك إختيار ما يناسبك فورمة - V4.xlsb

نعم أخي @نبا زيد يمكننا فعل دالك لاكن لدي إقتراح أعتقد أنه أفضل بدلا من تعديل الألوان مباشرة في الكود كل مرة يمكنك تحديد ألوان الخلفية ولون الخط بسهولة من داخل ورقة تمت إظافتها للملف بإسم الإعدادات كما هو موضح في الصورة التالية كل ما عليك فعله هو 1) تحديد اسم الحالة في العمود A مثل غائب - متأخر - مجاز - عطلة - حاضر - نهاية الأسبوع 2) اختيار اللون المناسب للخلفية في العمود B 3) اختيار اللون المناسب للخط في العمود C كل حالة سيتم تلوينها تلقائيا بناء على الألوان التي تحددها في ورقة الإعدادات مما يتيح لك تعديل الألوان في أي وقت بما يتناسب مع احتياجاتك دون التأثير على الكود أتمنى أن تجد هذه الفكرة مفيدة بالتوفيق Option Explicit Sub Remplissez() On Error GoTo SupApp Const FontName As String = "Arial" Const StartCol As Long = 5, TimeCol As Long = 4, NamArr As Long = 2 Const StartRow As Long = 7, LastCol As Long = 34 Dim xTime As String, Snt As String, Key As String, Icon As String Dim tmp As Object, tbl As Object, xColor As Object, xFont As Object Dim xAbsen As String, xName As String, DayName As String, Status As String Dim LastRow As Long, i As Long, col As Long, r As Long, n As Long, xDate As Date Dim f As Boolean, sWeekend As Boolean, a As Variant, b As Variant, c As Variant, j As Range Dim dest As Worksheet: Set dest = Sheets("الاستمارة") Dim CrWS As Worksheet: Set CrWS = Sheets("التواريخ") Dim WsSet As Worksheet: Set WsSet = Sheets("الإعدادات") Icon = ChrW(&H2714): xAbsen = ChrW(&H274C) Set tmp = CreateObject("Scripting.Dictionary") Set tbl = CreateObject("Scripting.Dictionary") Set xColor = CreateObject("Scripting.Dictionary") Set xFont = CreateObject("Scripting.Dictionary") For r = 2 To WsSet.Cells(WsSet.Rows.Count, "A").End(xlUp).Row Dim OnRng As String: OnRng = Trim(WsSet.Cells(r, 1).Value) If OnRng <> "" Then xColor(OnRng) = WsSet.Cells(r, 2).Interior.Color xFont(OnRng) = WsSet.Cells(r, 3).Interior.Color End If Next r SetApp False For r = 4 To CrWS.Cells(CrWS.Rows.Count, "A").End(xlUp).Row If Trim(CrWS.Cells(r, 3).Value) = "عطلة" Then tmp(CLng(CrWS.Cells(r, 1).Value)) = True Next r For r = 4 To CrWS.Cells(CrWS.Rows.Count, "E").End(xlUp).Row If CrWS.Cells(r, 5).Value <> "" And IsDate(CrWS.Cells(r, 6).Value) Then xName = Trim(CrWS.Cells(r, 5).Value) xDate = CrWS.Cells(r, 6).Value xTime = Trim(CrWS.Cells(r, 9).Value) Status = Trim(CrWS.Cells(r, 7).Value) Key = xName & "|" & CLng(xDate) & "|" & xTime tbl(Key) = Status If xTime = "صباحي/مسائي" Then tbl(xName & "|" & CLng(xDate) & "|صباحي") = Status tbl(xName & "|" & CLng(xDate) & "|مسائي") = Status End If End If Next r LastRow = dest.Cells(dest.Rows.Count, 4).End(xlUp).Row a = dest.Range(dest.Cells(StartRow, 1), dest.Cells(LastRow, LastCol)).Value b = dest.Range(dest.Cells(5, StartCol), dest.Cells(5, LastCol)).Value c = dest.Range(dest.Cells(6, StartCol), dest.Cells(6, LastCol)).Value For i = 1 To UBound(a, 1) If Trim(a(i, NamArr)) <> "" Then xName = Trim(a(i, NamArr)) For col = StartCol To LastCol n = col - StartCol + 1 If IsDate(b(1, n)) Then xDate = b(1, n): DayName = c(1, n): f = tmp.exists(CLng(xDate)) sWeekend = (DayName = "الجمعة" Or DayName = "السبت") xTime = Trim(a(i, TimeCol)) Key = xName & "|" & CLng(xDate) & "|" & xTime Status = IIf(tbl.exists(Key), tbl(Key), "") a(i, col) = IIf(f Or sWeekend Or Status = "غائب" Or _ Status = "مجاز" Or Status = "متأخر", xAbsen, Icon) End If Next col Next i dest.Range(dest.Cells(StartRow, 1), dest.Cells(LastRow, LastCol)).Value = a With dest.Range(dest.Cells(StartRow, StartCol), dest.Cells(LastRow, LastCol)) .Font.Name = FontName: .Font.Bold = True .Font.Color = vbBlack: .Interior.ColorIndex = xlNone For Each j In .Cells If j.Value = Icon Then If xColor.exists("حاضر") Then j.Interior.Color = xColor("حاضر") If xFont.exists("حاضر") Then j.Font.Color = xFont("حاضر") ElseIf j.Value = xAbsen Then Dim ColArr As Long: ColArr = j.Column - StartCol + 1 Dim RowArr As Long: RowArr = j.Row - StartRow + 1 xDate = b(1, ColArr) If Trim(a(RowArr, NamArr)) <> "" Then xName = Trim(a(RowArr, NamArr)) xTime = Trim(a(RowArr, TimeCol)) Key = xName & "|" & CLng(xDate) & "|" & xTime Status = IIf(tbl.exists(Key), tbl(Key), "") Snt = IIf(tmp.exists(CLng(xDate)), "عطلة", IIf(c(1, ColArr) = "الجمعة" Or _ c(1, ColArr) = "السبت", "نهاية الأسبوع", Status)) If xColor.exists(Snt) Then j.Interior.Color = xColor(Snt) If xFont.exists(Snt) Then j.Font.Color = xFont(Snt) End If Next j End With ExitSub: SetApp True MsgBox "تم تحديث البيانات بنجاح", vbInformation Exit Sub SupApp: Resume ExitSub End Sub Private Sub SetApp(ByVal enable As Boolean) On Error Resume Next Application.ScreenUpdating = enable Application.EnableEvents = enable Application.DisplayAlerts = enable Application.Calculation = IIf(enable, xlCalculationAutomatic, xlCalculationManual) End Sub استمارة-بعض النتائج المطلوبة v3.xlsb

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