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

السلام عليكم ورحمة الله تعالى وبركاته • هدية اليوم هى منتقى التواريخ تم الانتهاء من البرمجة والتطوير بالتعاون مع الاستاذ @Moosak ابداع وروعة وجمال تنسيق التصميم قام به اخى الحبيب و استاذى الجليل الاستاذ @Moosak كل الشكر والتقدير والامتنان على تعبه وحرصه على ان يخرج التطبيق بهذه الافكار الى النور فى ابهى صورة بهذا الشكل مميزات التطبيق وجود جدولين الجدول الاول : tblHolidaySettings هذا الجدول وظيفته هى التأشير على ايام العطلات الاسبوعية تبعا للمؤسسة وبذلك يتم تلوين ايام العطلات لتكون مميزة باللون الاحمر وهذا مثال لاختيار يوميى الجمعة والسبت الجدول الثانى : هذا الجدول وظيفتة اضافة تواريخ العطلات الرسمية للدولة و وصف العطلة عند الانتهاء من تسجيل كل العطلات الرسمية للدولة فى الجدول وبعد فتح منتقى التواريخ تبعا لكل شهر تظهر قائمة بالاعياد والمناسبات الرسمية ويتم تغيير لون خلفية اليوم ليكون معروفا من خلال النظر انه عطلة رسمية وبمجرد التحرك من الاسهم فى لوحة المفاتيح للمرور على الايام او اختيار اليوم بضغطة زر واحدة من الفأرة يتم ظهور وصف العطلة الرسمية فى اسفل مربعات الايام كما بالشكل التالى لاختار اليوم اما بالنقر مرتين على رقم اليوم او تحريك علامة الدائرة الزرقاء لتحديد اليوم من خلال ازرار الاسهم من لوحة المقاتيح ثم الضغط على زر اختيار والموجود بالاسفل يسار النموذج زر الامر المسمى اليوم الحالى ينقل فورا الدائرة الزرقاء الى رقم اليوم الذى يوافق تاريخ اليوم يمكن تغيير اتجاه ترتيب الارقام لتبدأ من اليمين الى اليسار او العكس من خلال الزر الموجود بجوار زر اليوم الحالى : ⇋ طريقة استدعاء الدالة لتعمل مع اى مربع نص يستخدم لادخال و كتابة التواريخ تكون كالاتى عمل زر امر بجوار مربع النص وفى منشئ التعبير لحدث النقر لهذا الزر يتم استدعاء الدالة بالشكل التالى على ان يتم تغير الوصف و اسم مربع النص تبعا لاغراض التصميم =CalendarFor([اسم مربع النص فى النموذج],"اكتب الوصف الدال على مربع نص التاريخ :") ملاحظة الوصف الذى سوف يتم كتابته اثناء استدعاء الدالة سوف يطهر فى اعلى يمين النموذج تحت زر الامر الغاء وان كان مربع النص الخاص بالتاريخ يحتوى بالفع على تاريخ سوف تجد هذا التاريخ ايضا تحت هذا الوصف وشرح الوظائف المختلفة للازرار من لوحة المفاتيح التى يمكن التعامل معها بسهولة موجود فى الزر اعلى اليسار " ؟ " اتمنى لكم تجربة شيقة واتمنى ان اكون قدمت اليكم شيئا عمليا ويعود عليكم بالنفع تم اضافة اصدار جديد لتنقيح وتفادى بعض الاخطاء بتاريخ 22/09/2024 - ضبط اسهم زيادة او نقصان الشهور والسنوات تبعا لترتيب واجهة ترتيب التواريخ ( يمين / يسار ) - ضبط الفتح التلقائى لقائمة السنوات او الشهور لاغلاقها اذا كانت مفتوحة بدلا من اعادة فتح القائمة مرة اخرى عند تكرارا الضغط رقم الاصدار الجديد 4 Handler - calendar (V3).zip Handler - calendar (V4).accdb

وعليكم السلام ورحمة الله تعالى وبركاته تفضل اخي لانشاء القائمة المنسدلة يمكنك اتباع الخطوات التالية لتنفيد طلبك والحصول على توسعة لنطاق البيانات بشكل ديناميكي دون الحاجة لتحديده مسبقا مع تجاهل الفراغات والقيم المكررة ضع الكود التالي في Module Sub Add_listeDéroulante() Dim lr As Long, arr() As String Dim cnt As New Collection Dim r As Range, rng As Range, i As Long Dim WS As Worksheet: Set WS = ThisWorkbook.Sheets("Sheet1") Dim dest As Worksheet: Set dest = ThisWorkbook.Sheets("Sheet2") lr = dest.Cells(dest.Rows.Count, 2).End(xlUp).Row On Error Resume Next For Each r In dest.Range("B4:B" & lr) If r.Value <> "" Then cnt.Add r.Value, CStr(r.Value) End If Next r On Error GoTo 0 If cnt.Count = 0 Then: Exit Sub ReDim arr(1 To cnt.Count) For i = 1 To cnt.Count arr(i) = cnt(i) Next i Set rng = WS.Range("B15:B24") With rng.Validation .Delete .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _ xlBetween, Formula1:=Join(arr, ",") .IgnoreBlank = True: .InCellDropdown = True: .ShowInput = True: .ShowError = True End With End Sub وفي حدث Sheet1 ضع الكود التالي سيتم جلب السعر عند التغيير أو الإضافة في عمود البيان وحساب القيمة عند الإدخال في عمود الكمية Private Sub Worksheet_Activate() Add_listeDéroulante End Sub Private Sub Worksheet_Change(ByVal Target As Range) Dim WS As Worksheet, data As Worksheet, result As Double Dim OnRng As Range, Search As Range, tmp As Range Dim lastRow As Long, i As Long, ColSum As Range On Error GoTo ErrorHandler Application.ScreenUpdating = False Application.EnableEvents = False Set WS = ThisWorkbook.Sheets("Sheet1") Set data = ThisWorkbook.Sheets("Sheet2") If Not Intersect(Target, WS.Range("B15:B24")) Is Nothing Then lastRow = data.Cells(data.Rows.Count, 2).End(xlUp).Row Set OnRng = data.Range("B4:B" & lastRow) For Each tmp In Intersect(Target, WS.Range("B15:B24")) If Not IsEmpty(tmp.Value) Then Set Search = OnRng.Find(What:=tmp.Value, LookIn:=xlValues, LookAt:=xlWhole) WS.Cells(tmp.Row, 4).Value = IIf(Not Search Is Nothing, Search.Offset(0, 1).Value, "") Else WS.Cells(tmp.Row, 4).Value = "" End If Next tmp End If If Not Intersect(Target, WS.Range("C15:D24")) Is Nothing Or _ Not Intersect(Target, WS.Range("B15:B24")) Is Nothing Then For i = 15 To 24 If IsNumeric(WS.Cells(i, 3).Value) And IsNumeric(WS.Cells(i, 4).Value) Then result = WS.Cells(i, 4).Value * WS.Cells(i, 3).Value WS.Cells(i, 5).Value = IIf(result <> 0, result, "") Else WS.Cells(i, 5).Value = "" End If Next i Set ColSum = WS.Range("E15:E24") If Application.WorksheetFunction.CountA(ColSum) = 0 Then WS.Range("E25").Value = "" Else WS.Range("E25").Value = Application.WorksheetFunction.Sum(ColSum) End If End If Application.EnableEvents = True Application.ScreenUpdating = True Exit Sub ErrorHandler: Application.EnableEvents = True Application.ScreenUpdating = True MsgBox "Erreur: " & Err.Description End Sub وأخيرا في حدث ThisWorkbook ضع السطور التالية لتحديث القوائم عند فتح الملف وحدفها عند الإغلاق تفاديا للأخطاء Private Sub Workbook_Open() Add_listeDéroulante End Sub Private Sub Workbook_BeforeClose(Cancel As Boolean) Dim WS As Worksheet Set WS = ThisWorkbook.Sheets("Sheet1") WS.Range("B15:B24").Validation.Delete End Sub بالتوفيق... فاتورة مبيعات مميزه 1.xlsm

هل افهم منك انك اعتمدت التعديل الذي رفعته لك ؟ اذا لا : لماذا اكلف نفسي بتعبئة ثلاث حقول نعم او لا .. والمطلوب اصلا نعم لنوع الحالة ... لأن الحالة واحدة ولا يمكن ان يأخذ نعم في اكثر من واحدة لذا الاولى والافضل اختيار الحالة من الحالات الثلاث ، وهذا انت ترى التعثر في التصفية من البداية ..

نعم في الأحوال العادية + تعمل عمل & ... ولكن عندما تجمع + قيمة معينة مع قيمة = Null فإن المجموع دائما يساوي Null . تماما كما يكون حاصل ضرب أي عدد في صفر فإن الناتج دائما يساوي صفر 🙂 لذلك عندما نقول ( "-" + Text2) مثلا .. فإن Text2 يحل محلها القيمة التي تكتبها في مربع النص ، أما إذا كانت فارغة فإنه تحل محلها القيمة Null فتكون المعادلة بذلك ( "-" + Null ) = Null وهذا ما يفسر إختفاء الشرطة في حال أن قيمة الحقل فارغة . 🙂 ولو فحصنا ذلك في نافذة الإميديت سنجد : ولكن لو استبدلنا الـ + بال & سنجد أن النتيجة ستصبح هكذا : الشرطة التي ظهرت هي الشرطة التابعة للـ Text3 🙂 لاحظ أنني غيرت موضعها في الكود عن كودك الأصلي 😎✌

اخوي فؤاد لا تزعل اذا قلت لك تصميمك ( كإدخال بيانات) في الجدول خطأ حاول تبسيط الامور دائما .. خطوة واحدة بدلا من ثلاث خطوات انظر التعديل test2.rar

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

نعم وصلت الفكرة .. وهذه هي الأصل .. وانت صح .. يبدوا اني لم اجرب .. دعني القي نظرة

😃 عجيب 😃 فسر لنا .. اليست + تعمل عمل & ؟ الــــــــ Text2 + "-" التي ظهرت 89 اين الشرطة ؟ بفتح الشين وليس ضمها ههههههههه

إدن هدا سوف يوفي بالغرض Sub Supp_lignes_Returns_formulas() Dim lr&, j&, i&, a, OnRng As Range Dim arr() As Variant, tmp As Variant Dim f As Worksheet: Set f = ActiveSheet lr = f.Columns("C:P").Find(What:="*", _ SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row Set OnRng = f.Range("C7:P" & lr) tmp = OnRng.Value Application.ScreenUpdating = False ReDim arr(1 To UBound(tmp, 1), 1 To UBound(tmp, 2)) a = 1 For i = 1 To UBound(tmp, 1) If tmp(i, 2) <> "" And _ WorksheetFunction.CountA(Application.Index(tmp, i, 0)) > 0 Then For j = 1 To UBound(tmp, 2) arr(a, j) = tmp(i, j) Next j a = a + 1 End If Next i If a > 1 Then f.Range("C7:P" & lr).ClearContents f.Range("C7").Resize(a - 1, UBound(arr, 2)).Value = arr Else f.Range("C7:P" & lr).ClearContents End If Application.ScreenUpdating = True End Sub test002.xlsm

وهذا تطبيق نوعا ما للفكرة .. xx.rar

بالنسبة لهده النقطة قد تم تعديلها لدمج بيانات مثلا السابعة و السابعة مهندسين في ورقة واحدة اما بخصوص البحث اظن انك بحاجة لتغيير طريقة البحث لتتمكن من فرز البيانات بجزء من قيمة البحث على جميع الأعمدة انصحك باستخدام نمودج مستخدم (يوزرفورم) سيوفر لك سرعة جلب البيانات خاصة ان ملفك الاصلي يتضمن ما يقارب 10 الف موظف الموظفين 2.xlsb

هذا واحد منها

السلام عليكم 🙂 هناك قوالب جاهزة لهذا العمل: الشرح : https://access-templates.com/tutorial/vehicle-fleet-management-solutions-using-microsoft-access-database.html و خمسة قوالب : https://access-templates.com/tag/vehicle+maintenance.html كما ان شركة مايكروسوف عندها قوالب جاهزة في الاكسس ، ويمكن انزال البقية من هنا : https://support.microsoft.com/en-us/office/featured-access-templates-e14f25e4-78b6-41de-8278-1afcfc91a9cb?ui=en-us&rs=en-us&ad=us وفيه لصيانة المعدات . وهناك برنامج للبيع والذي يمكن انزال نسخة تجريبية منه ومعرفة مكوناته وطريقة عمله : http://www.granitefleet.com/ وبالتوفيق 🙂 جعفر

ماكرو اخر يقوم بنفس المهمة Option Explicit Sub FIND_EMPLOY() Dim mPath$ Dim F_Name, TS$ Application.ScreenUpdating = False If UCase(ActiveSheet.Name) <> "SALIM" Then GoTo BAY_BAY_YA_HILWEEN mPath = ThisWorkbook.Path & "\" F_Name = mPath & "[Empl.xlsx]" F_Name = F_Name & "DATA'!$A$2:$J$100" Range("B3").Resize(, 9).ClearContents TS = "VLOOKUP($A3,'" & F_Name & ",COLUMNS($A$1:B1)" & ",0" & ")" TS = "=IFERROR(" & TS & ","""")" With Range("B3").Resize(, 9) .Formula = TS .Value = .Value End With If Range("B3") = vbNullString Then MsgBox "THIS CODE :" & Chr(10) & _ """" & Range("A3") & """" & Chr(10) & _ "DOES'T EXITS IN WORKBOOK "" Empl.Column(A)"" " Range("A3").ClearContents End If BAY_BAY_YA_HILWEEN: Application.ScreenUpdating = True End Sub