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

السلام عليكم ورحمة الله وبركاته جرب التعديل التالي جدول التفريغ V2 (1).xlsm

السلام عليكم أعضاء منتدى أوفيسنا الغاليين في محاولة مني لاستثمار بعض اوقات الفراغ حاليا وايضا لاثراء المنتدى الجميل باي شكل اقدر عليه عسى ان تنفع مبتديء في مجال VBA حاولت استفيد من قدرات الذكاء الصناعي بشكل ما وقلت اعمل شرح وافي شامل بقدر المستطاع للـ VBA يشمل اكبر قدر ممكن من الامثلة والاوامر وقلت طبعا اشاركه هنا مع بعض لعله فيه افاده لاي أحد طبعا انا معملتش اي حاجة غير نسخ ولصق وشوية تنسيق بسيط جدا بس علشان ينفع يقرأ اي احد يقرأه ويستفيد ان شاء الله ولاحظ اي اخطاء املائيه او تنسيقية او اخطاء في الاكواد نعدلها والله الموفق واعذروني للتقصير مرفق الفصل الاول والثاني والثالث واذكركم بس دا كتاب تم تأليفه بواسطة السيد ذكاء بيه الاصطناعي يعني مش انا وكمان مفيش تنسيق ولا مراجعه بالقدر .. العمر بيفرق والنظر راح وربنا يوفق يارب Ch1 Ch2 Ch3

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

رداً للجميل في هذا المتدى المتميز، أرفق إليكم هذا الملف لإدارة الميزانية الشخصية، والذي استخدمت فيه دالة pivotable ودمجتها بدالة filter ، وتم عرض الملف بداش بورد جميل ومرتب.. تحياتي للجميع. الميزانية الشخصية.xlsm

إثراءا للموضوع يمكنك توسيع منع التكرار على عدة أعمدة مثلا 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

وعليكم السلام ورحمة الله تعالى وبركاته ضع هدا في حدث ورقة معلمين Option Explicit Private Const ShName As String = "معلمين" Private Sub Worksheet_Calculate() Static tmps As Boolean If tmps Then Exit Sub tmps = True If Not IsEmpty(Me.Range("D5").Value) Then Coloring_Classes tmps = False End Sub Sub Coloring_Classes() Dim Sh As Worksheet: Set Sh = ThisWorkbook.Sheets(ShName) On Error GoTo HandleError Application.ScreenUpdating = False: Application.EnableEvents = False Application.Calculation = xlCalculationManual xColor Sh, Sh.[D5].Value, "C7:I11" xColor Sh, Sh.[D18].Value, "C20:I24" xColor Sh, Sh.[D30].Value, "C32:I36" Cleanup: Application.ScreenUpdating = True: Application.EnableEvents = True Application.Calculation = xlCalculationAutomatic Exit Sub HandleError: Resume Cleanup End Sub Sub xColor(ws As Worksheet, Search As String, cnt As String) Dim xCell As Range, xRng As Long, OnRng As Range, ky As Variant Dim r As Long, c As Long, n() As Long Set OnRng = ws.Range(cnt) If Trim(Search) = "" Then: OnRng.Interior.ColorIndex = xlColorIndexNone: Exit Sub Set xCell = ws.Range("Q2:Q" & ws.Cells(ws.Rows.Count, "Q").End(xlUp).Row) _ .Find(What:=Search, LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False) If xCell Is Nothing Then: OnRng.Interior.ColorIndex = xlColorIndexNone: Exit Sub xRng = xCell.Offset(0, 1).Interior.Color ky = OnRng.Value ReDim n(1 To UBound(ky, 1), 1 To UBound(ky, 2)) For r = 1 To UBound(ky, 1) For c = 1 To UBound(ky, 2) If Not IsError(ky(r, c)) And Len(Trim(ky(r, c))) > 0 Then n(r, c) = xRng End If Next c Next r OnRng.Interior.ColorIndex = xlColorIndexNone For r = 1 To UBound(n, 1) For c = 1 To UBound(n, 2) If n(r, c) <> 0 Then OnRng.Cells(r, c).Interior.Color = n(r, c) End If Next c Next r End Sub جدول التفريغ V2.xlsm

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

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

مشاركة مع استاذى الجليل و معلمى القدير الاستاذ @ابو عارف وبعد إذن أستاذى هناك بعض الحالات التي قد تستوجب تعديلات إضافية لضمان التوافق بين الأنوية المختلفة (32 بت و 64 بت) وكذلك بين إصدارات الويندوز وأوفيس المختلفة عند التعامل مع دوال الـ API في VBA و يجب الانتباه لها: في النظام 32 بت، النوع Long يستخدم بشكل طبيعي لتخزين المؤشرات (pointers)، لكن في النظام 64 بت، يجب استخدام LongPtr بدلاً من Long لتخزين المؤشرات. المشكلة: إذا لم تستخدم LongPtr في النظام 64 بت، فقد تحدث أخطاء في الحسابات التي تتعلق بالحجم أو العناوين، لأن الـ Long لا يدعم العناوين الأكبر في الأنظمة 64 بت. ملاحظة: في الأنظمة 64 بت، LongPtr قادر على التعامل مع الأرقام التي تتجاوز سعة الـ Long العادية (التي تصل إلى 2,147,483,647). في الأنظمة 32 بت، LongPtr يتم تحديده تلقائيًا ليكون Long. التعامل مع السلاسل النصية (Strings) في بعض الأحيان، قد تحتاج إلى تعديل طريقة تعريف السلاسل النصية المستخدمة مع الـ API إذا كنت تستخدم سلاسل نصية مع الـ API، تأكد من إضافة ByVal و ByRef بشكل صحيح استخدم String * n بدلاً من String في بعض الحالات التي تتطلب أن تكون السلسلة ثابتة الطول التعامل مع الهياكل (Structures) في بعض الأحيان، تستخدم الهياكل (مثل Type في VBA) مع دوال الـ API. إذا كنت تستخدم هياكل كبيرة، فقد تحتاج إلى التأكد من أن الأنواع داخلها متوافقة مع النظام 64 بت تأكد من أن جميع الهياكل تتعامل بشكل صحيح مع الأنواع مثل LongPtr بدلاً من Long أو Integer عندما يتعلق الأمر بالمؤشرات لأنه قد يتغير حجم الحقول في الهيكل بين الأنوية 32 و 64 بت، مما يسبب أخطاء في التعامل مع الذاكرة أو المؤشرات التأكد من استخدام #If و #ElseIf بشكل مناسب عند التعامل مع دوال API في VBA وتحديد التوافق بين الأنظمة 32 بت و 64 بت، تأكد من استخدام #If, #ElseIf و #End If بشكل صحيح عند تخصيص الوظائف للأجهزة ذات الأنوية المختلفة. الشرح السابق يوضح الفرق فى التعامل مع النواتان و كتابة الكود بشكل صحيح ليصبح الكود متوافقا بين النواتان لانه لو قمت بالاستبدال لن يعمل على النواة 32

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)

تفضل استاذ @ابو عبد الله العراقي محاولتي حسب مافهمت . اليك الكود بعد التعديل . MergMic_KH_3.rar

Try #If VBA7 Then 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 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 Function CreateElevatedFile(ByVal sFilePath As String, ByVal sFileContent As String) As Boolean On Error GoTo ErrorHandler Dim fso As Object, sScriptPath As String, psScript As String, EscFilePath As String, EscContent As String sScriptPath = Environ("TEMP") & "\create_elevated_file.ps1" EscFilePath = Replace(Replace(sFilePath, "'", "''"), """", "\""") EscContent = Replace(Replace(sFileContent, "'", "''"), """", "\""") psScript = "$t = [System.Diagnostics.ProcessWindowStyle]::Hidden;$p = Start-Process -WindowStyle $t -FilePath 'powershell.exe' -ArgumentList '-Command ""Set-Content -Path \""" & EscFilePath & "\""` -Value \""" & EscContent & "\""""' -Verb RunAs -PassThru;$p.WaitForExit();Exit $p.ExitCode" Set fso = CreateObject("Scripting.FileSystemObject") With fso.CreateTextFile(sScriptPath, True) .WriteLine psScript .Close End With ShellExecute 0, "runas", "powershell.exe", "-ExecutionPolicy Bypass -WindowStyle Hidden -File """ & sScriptPath & """", vbNullString, 0 CreateElevatedFile = True Exit Function ErrorHandler: CreateElevatedFile = False End Function Sub Create_File_With_Elevated_Permissions() Dim success As Boolean success = CreateElevatedFile("C:\Windows\Test.txt", "This Was Created With Elevated Permissions") If success Then MsgBox "File Created Successfully", vbInformation Else MsgBox "File Not Created", vbExclamation End If End Sub

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

لم أنتبه للجداول السفلى على العموم تم تعديل الكود ليتناسب مع طلبك في المشاركة السابقة اما بخصوص ورقة جدول Option Explicit Private Const ShName As String = "جدول " Private Const OnRng As String = "B6:AJ23" Private Const début As Long = 5 Private Const lastCol As Long = 36 Private Const linge As Long = 2 Sub Coloring_Classes() On Error GoTo EndClear SetApp False Dim Sh As Worksheet: Set Sh = ThisWorkbook.Sheets(ShName) Dim i As Long, r As Long, c As Long, ColAL As Long, ColA As Long Dim tmps As Object: Set tmps = CreateObject("Scripting.Dictionary") Sh.Range(OnRng).Interior.ColorIndex = xlNone ColAL = Sh.Cells(Sh.Rows.Count, "AL").End(xlUp).Row ColA = Sh.Cells(Sh.Rows.Count, "A").End(xlUp).Row For i = début To ColAL If Len(Sh.Cells(i, "AL").Value) > 0 Then If Sh.Cells(i, "AM").Interior.ColorIndex <> xlColorIndexNone Then tmps(Sh.Cells(i, "AL").Value) = Sh.Cells(i, "AM").Interior.Color End If End If Next i For r = début To ColA If tmps.exists(Sh.Cells(r, "A").Value) Then For c = linge To lastCol With Sh.Cells(r, c) If Len(.Value) > 0 Then .Interior.Color = tmps(Sh.Cells(r, "A").Value) End With Next c End If Next r EndClear: 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 جدول التفريغ V3.xlsm

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

الفصل الثالث CH3.docx

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

سلمت يمناك مولانا @ابو جودي 😃🖐 ... إضافة مميزة وتنسيق يدل على جمال وإتقان صاحبه 😎✌ تم إضافة النسخة الجديدة بتنسيقات وتحسينات المعلم المبدع @ابو جودي

صراحة لم أنتبه أنه هناك ورقة أخرى على الملف يجب تنفيد المطلوب عليها على العموم قد تم تنفيده من الأستاد @عبدالله بشير عبدالله بالتوفبق

وعليكم السلام ورحمة الله تعالى وبركاته Option Explicit Private Const ShName As String = "جدول عام" Sub Coloring_Classes() On Error GoTo EndClear SetApp False Dim Sh As Worksheet: Set Sh = ThisWorkbook.Sheets(ShName) Dim i As Long, r As Long, c As Long, ColAL As Long, ColA As Long Dim tmps As Object: Set tmps = CreateObject("Scripting.Dictionary") Sh.Range("B6:AJ23").Interior.ColorIndex = xlNone ColAL = Sh.Cells(Sh.Rows.Count, "AL").End(xlUp).Row ColA = Sh.Cells(Sh.Rows.Count, "A").End(xlUp).Row For i = 5 To ColAL If Len(Sh.Cells(i, "AL").Value) > 0 Then If Sh.Cells(i, "AM").Interior.ColorIndex <> xlColorIndexNone Then tmps(Sh.Cells(i, "AL").Value) = Sh.Cells(i, "AM").Interior.Color End If End If Next i For r = 5 To ColA If tmps.exists(Sh.Cells(r, "A").Value) Then For c = 2 To 36 With Sh.Cells(r, c) If Len(.Value) > 0 Then .Interior.Color = tmps(Sh.Cells(r, "A").Value) End With Next c End If Next r EndClear: 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 جدول.xlsm

تفضل كود إخفاء (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

نعم أخي يمكننا فعل دالك للتوضيح : تم إظافة تحديث الإسم الكامل للموظف عند الإدخال مباشرة للمعاينة فقط لأنه في الأصل يحدث عند كل ترحيل أو تعديل للبيانات المرفقات https://www.mediafire.com/file/bq3nkauzlo9j3jt/بيانات+الموظفين+v2.rar/file تم رفعه في المشاركه قاعدة بيانات الموظفين 2 .xlsm بيانات الموظفين v2.rar

بأقرب فرصة إن شاء الله 😇 .

اشكر مرورك الكريم اخى الفاضل

وعليكم السلام ورحمة الله وبركاته 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

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

اخي واستاذي @Foksh اولا لكم مني جزيل الشكر على مرورك الكريم وسرعة الاستجابه هذا بالفعل هوا المطلوب

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

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

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

مين قال لك تقول على وتكتب اسمى ع التطبيق انا ما عملت اى شئ

السلام عليكم اولا : نبارك لك اخي احمد .. في بداية خطواتك نحو طريق البرمجة الصحيح ثانيا : مازلت تقدح من رأسك واعذر اخوك الكبير على هذه العبارة الملاحظات السلبية : - عمل جداول زائدة ستكون عبئا في نهايات ونتائج البرنامج - الاهتمام بالفرعيات والجزئيات واهمال الأساسات من الفرعيات عملية العلاقات وأعطائها اهمية من الاساسيات : تحليل البيانات تحليل البيانات فيما يخص برنامجك : هو ان تشرح خصوصية برنامجك ، لأن البرنامج عبارة عن ( مشتريات ومبيعات ) وهذ مشروع معروف ومتداول ومفهوم لدى اغلب المبرمجين فلا حاجة للتفاصيل الخصوصية مثلا : - هل هو نقاط بيع ( بالنقد والكاش ) ام يشتمل على جزئية البيع بالآجل ، ام هو فقط بيع بالآجل ، او اي خصوصية توجد في المشروع غير موجودة في المشاريع العادية الخلاصة : انت في بداية مشوارك .. فلا تترك الاستشارة في كل صغيرة وكبيرة لا تخرج من الجداول حتى يتم احكامها 100% حتى لو جلست على اعدادها فترات طويلة مازلت اقول واكرر ان ضبط الجداول بصورة صحيحة هو انجاز 80% من المشروع ............................. فائدة : عندما انشء حقلا في جدول فحينها اتصور او استحضر اماكن ظهور هذا الحقل في الاستعلامات او التقارير بمعنى اني استحضر المخرجات ( التقارير ) في بالي وكأني أراها في الوقت الذي اعمل على تصميم الجداول كتبت هذه الملحوظات آمل ان تجد الفائدة اعانك الله ووفقك

وعليكم السلام ورحمة الله وبركاته .. لعدم وضوح كامل الصورة من المطلوب من جهة علاقة الجداول ببعضها البعض من خلال مفتاح الربط = مساحة القطعة ، تم ربط الجدولين بعلاقة One-To-Many ، أيضاً علاقة المالك لم تكن واضحة في النموج ، لذا تركت دون تغيير . واليك المرفق التالي جربه واخبرني بالنتيجة .. مساحات.accdb

انا حصلت دالتين فيهما شوية حول .. وصححت لهما النظر Database70.rar

تم التعديل استمارة الكترونية1.xlsm

وعليكم السلام ورحمة الله وبركاته الطريفة الاولى قبل حفظ الملف ارجع الى الصفحة الرئيسية ثم حفظ الطريقة الثاتية عن طريق كود وسيقوم بفتح الصفحة الرئيسية حتى لو قمت بالحفظ عند ورقة 10 مثلا ضع هذا الكود في محرر الاكود في ThisWorkbook Private Sub Workbook_Open() Sheets("SHEET1").Activate End Sub طبعا غير اسم SHEET1 بالكود باسم الشيت الرئيسى لديك

ومشاركة مع استاذى واخى الحبيب الاستاذ @Foksh طريقتى المتواضعة zint barcode generator V2.zip

الدرس الثالث: استخدام جهاز قارئ الباركود في الإكسيل كثير من الناس يعتقد أن استخدام جهاز قراءة الباركود يحتاج نظام وأجهزة خاصة للتعامل معه، ولكن الأمر أبسط مما كنت أتوقعه، في ا لدرس الأول حللنا عقدة تكوين شريط الباركود ، لم يبق لدينا إلا أن نربطه في قاعدة البيانات في الإكسيل. كل ما عليك هو التالي: 1- طباعة ملصقات الباركود على ورقة A4. 2- بناء قاعدة البيانات في الإكسيل. 3- بناء صفحة الإدخال في الإكسيل. بالنسبة لآلية عمل جهاز القارئ يكون لو بعملتين هما: كتابة الكود ثم enter. فلذلك ينتقل مؤشر الماوس إلى السطر التالي. ولكي نجعل المؤشر يبقى في مكانه نقوم بحماية الصفحة (انظر الشرح في الملف المرفق) لا أعتقد أنكم تحتاجود درس آخر .. لأننا وصلنا إلى الفكرة ومبرووووك عليكم التعامل مع الباركود. barcode reading.rar

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

طريقتان لأستخدام ال ( CHECK BOX ) ولكن يمكن الأستفادة منها بطرقا عدة وغير منتهية ولكن لجاذبية وجمال شكلها أردت أن أقدمها كفكرة يمكن الأستفادة منها لأنها غير مستخدمة بكثرة CHECK BOX.rar

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