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

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

تفضل حدول 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

مشاركة مع استاذى الجليل و معلمى القدير الاستاذ @ابو عارف وبعد إذن أستاذى هناك بعض الحالات التي قد تستوجب تعديلات إضافية لضمان التوافق بين الأنوية المختلفة (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

اعرض الملف ⚙🛠🎁 أداة لإصلاح وتعديل النصوص العربية التالفة في الأكواد .. من > ÇáÓáÇã Úáíßã إلى > السلام عليكم :: السلام عليكم ورحمة الله وبركاته :: نظرا لوجود مشكلة عند نسخ النصوص العربية في أكواد VBA وخصوصا عندما تكون لغة النظام معينة على اللغة الإنجليزية .. لذلك قمت بتصميم هذه الأداة لتقوم بإصلاح العبارات العربية التالفة في الكود وإرجاعها إلى أصلها ... مثال : ÇáÓáÇã Úáíßã >>>> تعود لأصلها : السلام عليكم وهذه صورة للأداة : صاحب الملف Moosak تمت الاضافه 04/22/25 الاقسام قسم الأكسيس  

الفصل الثالث 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

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

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

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

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

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

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

اختصارا للوقت المتوقع للشروحات مستقبلا اليك مثالين مختصرين متشابهين تقريبا حاول العمل عليهما والتجربة من اجل تلم بفكرة الجدول الواحد وناقش ما يهمك من خلالهما .. New folder.rar

تحياتي أستاذ FOKSH وشكراً لمرور حضرتك الكريم المطلوب حضرتك عند إختياري لأي مساحة من الكمبوبوكس تظهر ليا تفاصيل هذة المساحة في باقي الحقول ( الردود ( أمامي ـ خلفي ـ جانبي ) .. وأبعاد المبنى ومساحة المبنى ... الخ

طيب ، تقدر تنشئ حقلين ( Start_Sec و End_Sec ) في الجدول Tb_Tawze_Leyaka لتسجيل تاريخ و وقت بداية ونهاية الجلسة لكل مجموعة . وارسال المرفق بعد التعديل وغداً ان شاء الله سنحاول ضبط الأمور أكثر

بإذن الله تعالى ,, في هذا الشق :- (شهادة كفالة وموارد) وهي اضافة الابناء المختارين في كفالة احد الازواج فالمشكلة ظهور طفل واحد وفما حالات تكون فيها ظهور طفلين او اكثر حاول اضافة أكثر من ابن للسجلات مع ارفاق الملف الجديد لرؤية النتيجة على أرض الواقع

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

يا عم انا فاهم عليك والله .. الفكرة بتاعتك من حيث الترتيب حسب المادة بتستخدم دالة مخصصة GetMaterialSortOrder لترتيب ديناميكي ، مش زي فكرتي وغيره من أمور زي مثلاً انه كودك وفكرتك من حيث المرونة والتعديل بتعتمد على دوال يمكن تعديلها بشكل مركزي من خلال الكود . أما فكرتي فبتعتمد على ثابت داخل الاستعلام ، يصعب تحديثه انت أمنتني وانا مش هنكر ههههههه حبيبي وانت عارف معزتك عندي

وإياكم اخي الكريم

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

وعليكم السلام ورحمة الله تعالى وبركاته هذا يتطلب ببساطة تحديد حجم ثابت للدوائر بدلا من حسابه بناء على حجم الخلايا يمكنك تغيير هذه القيمة حسب الحجم الذي ترغب فيه tmp = 10 Option Explicit Sub DrawCircles() Const SROW As Long = 6, EROW As Long = 10, SCOL As Long = 2, ECOL As Long = 9 Dim ws As Worksheet, sColName As String, i As Long, j As Long, n As Long, tmp As Double Application.ScreenUpdating = False Call DelShap Set ws = ActiveSheet tmp = 10 For i = SROW To EROW With ws n = .Range("k" & i).Value For j = ECOL To SCOL Step -1 If .Range(.Cells(i, j).Address).Value <> Empty And n > 0 Then sColName = Split(.Cells(1, j).Address, "$")(1) With ActiveSheet.Shapes.AddShape(msoShapeOval, _ .Range(sColName & i).Left + 0.5 * (.Range(sColName & i).Width - 2 * tmp), _ .Range(sColName & i).Top + 0.5 * (.Range(sColName & i).Height - 2 * tmp), _ 2 * tmp, 2 * tmp) .Line.Weight = 2 .Line.ForeColor.RGB = RGB(10, 10, 10) .Fill.Visible = msoFalse End With n = n - 1 End If If n = 0 Then Exit For Next j End With Next i Application.ScreenUpdating = True End Sub

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

هو الحل مثل ما قال شيخنا ابو خليل ربي يمتعه بالصحة عند تصغير مربع نص اي جهاز لايقرا الباركود فالحل بالنسبة لي ليس الاضافة من نوع ( barcodex.ocx ) كما قال عليها الاستاد جعفر ان الشركة ستلغي استخدام هدا النوع من الملفات لاسباب امنية الله اعلم الموضوع عند الاستاد جعفر فانا لم اتعمق فيه ما تعلمته من بحر البرمجة (ادا اردت النجاح - فاشتري ما تريد العمل به ) فهدا ما سافعل ابتداء من البرامج التي استخدمها الى الخط التجاري مثل باركود كي لا تواجهني اي انتقادات من المشتري وهدا مثال بسيط , طباعة ورقة (A4 ) وطبــاعة ملصقــات ( Role ) على الباركود الدي استخدمه فهو فعال مع جميع الاجهزة عبار عن موديول لخط ( Code128 ) اي استفسار او ملاحظة انا موجود بادن الله كما انوه للاخوة الدين يشتغلون في هدا المجال - الامور قد تطورت لابعد حدود مع الدكاء الاصطناعي فما كان المبرمج يبحث عن مساعدة او تطوير يستغرق من وقته عدة اسابيع او لنقول مدة طويل اليوم مع الدكاء الاصطناعي , مشروع لا ياخد منك اكثر من اسبوع بتصحيح اخطاء التي نقع فيها ادا كان البرنامج كبير فما عليكم الى بهاد الموقع وهو مجاني https://chatgpt.com/ ويوجد مواقع اخرى في عدة مجالات مجانية ومدفوعة فسؤالك بنسبة للبرمجة بجميع انواعها ستجد امثلة P_barcode.accdb

اخي الكريم استخدم المعادلة التالية للوظيفة =IFERROR(VLOOKUP(D2,$A$2:$B$18,2,0),"") وهذه للاقامة =IFERROR(VLOOKUP(D2,$A$2:$C$18,3,0),"") تقبل تحياتي

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

بسم الله الرحمن الرحيم الكثير منا بعد تعب شاق في برنامجه يريد أن يحميه من عبث الآخرين او حمايته لأهميته الشخصية تتعدد متطلبات الحماية ولكن تبقي المشكلة عند معظم مستخدمي الاكسيل من مبتدئ لمتوسط او لاكثر قليلا يوفرو لعملهم بعض الحماية ولكن يتضح انه يوجد نقاط ضعف كثيرة وكل ما يقوم بسد نقطة تظهر اخرى حتى يمل من هذا الموضوع ولكن الان اضع بين ايديكم نموذج لحماية ملفك برقم سيريال الهارد الخاص بك أي انه ان قام احد بنقل البرنامج بدون علمك فلن يعمل في أي مكان اخر الا اذا قمت انت بتفعيلة عن طريق ادخال كلمة المرور الخاصة بصاحب البرنامج ومنها تقوم بالتعديل علي السيريال ومرفق اداة منفصلة لاظهار السيريال نمبر للهارد ستحتاجها في تسويق عملك بمعني طلب منك احد الاشخاص عمل برنامج له بمقابل مادي بعد ان تنتهي من برنامجه ترسل له الأداة لإظهار رقم الهارد وتقول له افتح الاداة من علي الجهاز المراد تشغيل البرنامج عليه ويرسل لك رقم الهارد وتقوم بتسجيله في البرنامج وبس يامعلم جربوا البرنامج وبلغوني التقييم اكيد وحش كالعادة صح كلمة مرور التأكيد :123 DiskSerial.rar ان لم يظهر رقم الهارد في الاداة عند الضغط علي الزر فقم بتشغيل الاداة في وضع كمسئول