كل الانشطه

وعليكم السلام ورحمة الله وبركاته ,,, بعد عدة محاولات من خلال المعادلات ، وجدت أنه من الصعب عدم تحديث الخلايا الغير معنية بالإدراج ، لذا توجهت الى استخدام الماكرو التالي :- Sub FokshCheckBox() Dim chk As CheckBox Dim rng As Range Dim rowNum As Long For Each chk In ActiveSheet.CheckBoxes Set rng = chk.TopLeftCell rowNum = rng.Row If chk.Value = xlOn Then If IsEmpty(Cells(rowNum, "A").Value) Then Cells(rowNum, "A").Value = Now End If ElseIf chk.Value = xlOff Then Cells(rowNum, "A").ClearContents End If Next chk End Sub وعليه ، فيتم استدعائه في جميع الـ CheckBoxes التي لديك فقط ، دون ربط العناصر ببعضها .. ملفك بعد التعديل ، جرب وأخبرنا بالنتيجة مربع اختيار يضيف التاريخ والوقت عند الاختيار.zip

وعليكم السلام ورحمة الله تعالى وبركاته جرب هدا Option Explicit Sub Transfer() Dim a As Long, b As Long, colMap(0 To 4) As Long, tmp(0 To 4) As Boolean Dim srcArr As Variant, destArr As Variant, dict As Object, i As Long, j As Long, f As Long, lr As Long Dim xDate As String, lastRow As Long, xName As String, c As Boolean, xCode As Boolean, Irow As Range, val Dim CrWS As Worksheet, Data As Worksheet Set CrWS = Sheets("Sheet2"): Set Data = Sheets("Sheet3") Set dict = CreateObject("Scripting.Dictionary") xDate = Format(CrWS.Range("D2").Value, "dd/mm/yyyy") If xDate = "" Then MsgBox "المرجوا تحديد التاريخ", vbInformation: Exit Sub With Data For a = 5 To .Cells(3, .Columns.Count).End(xlToLeft).Column If Format(.Cells(3, a).Value, "dd/mm/yyyy") = xDate Then f = a: Exit For End If Next If f = 0 Then MsgBox "لم يتم العثور على التاريخ", vbExclamation: Exit Sub Set Irow = .Columns("E:P").Find("*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows) lr = IIf(Irow Is Nothing Or Irow.row < 5, 5, Irow.row) .Range(.Cells(5, f), .Cells(lr, f + 4)).ClearContents End With lastRow = CrWS.Cells(CrWS.Rows.Count, "C").End(xlUp).row srcArr = CrWS.Range("C12:H" & lastRow).Value For i = 6 To Data.Cells(Data.Rows.Count, "D").End(xlUp).row If Not dict.exists(Data.Cells(i, "D").Value) Then dict(Data.Cells(i, "D").Value) = i End If Next For j = 0 To 4 xName = CrWS.Cells(10, 4 + j).Value For b = 0 To 4 If Data.Cells(4, f + b).Value = xName Then colMap(j) = f + b Exit For End If Next Next For i = 1 To UBound(srcArr, 1) If srcArr(i, 1) <> "" Then If dict.exists(srcArr(i, 1)) Then xCode = True For j = 1 To 5 val = srcArr(i, j + 1) If Not IsEmpty(val) Then c = True Data.Cells(dict(srcArr(i, 1)) + 5, colMap(j - 1)).Value = val If Not tmp(j - 1) Then Data.Cells(5, colMap(j - 1)).Value = CrWS.Cells(11, 3 + j).Value tmp(j - 1) = True End If End If Next End If End If Next Select Case True Case c: MsgBox "تم ترحيل البيانات بنجاح", vbInformation Case Not xCode: MsgBox "لم يتم العثور على أي أكواد مطابقة", vbExclamation Case Else: MsgBox "لا توجد بيانات لترحيلها", vbInformation End Select Book2 -v2.xlsb

عمل رائع وجميل وحدات نمطية وأكواد متعوب عليها في اعمالي اقتصر غالبا قدر استطاعتي على الادوات التي يملكها اكسس .. فالساعة مثلا لا اخرج عن هذا السطر: Private Sub Form_Timer() Me.Label2.Caption = Format(Now, "hh:nn:ss AM/PM") End Sub ولكني وظفت العداد في عملية مهمة لضبط الإدخال في عملية الحضور وقد جعلت الفورم يملأ الشاشة .. فكانت فكرة اظهار الساعة مستحسن ومناسب الفكرة التي راودتني حين طرحت الموضوع هي .. هل يمكنني جلب ساعة وندز الى الفورم بسطر واحد ؟ مثل سطر جلب مستخدم وندوز : CreateObject("WScript.Network").UserName او رقم المعالج : Environ("NUMBER_OF_PROCESSORS") واشياء اخرى يمكن جلبها او تشغيلها ومناداتها بسطر

عمل جميل جدا ولكن هناك عدة ملاحظات ١ لا يوجد بالكشف مراقبين أدوار ٢مامعنى جدول ملاحظة٣ اين المراقب الاول ومراقب الكنترول ورئيس اللجنة انا بتكلم على الشهادة الثانوية وليس النقل٤ كشف الملاحظة انظر للملف المرفق اريد مثله بالضبط واخيرا لك الف تحية وسلام على المجهود والرد

السلام عليكم ورحمة الله وبركاته هذا ملف للملاحظة اشتغلت عليه به اكواد من ملفات بعض الزملاء بهذا الموقع وغيره ( لم اقم بنسبتها لنفسى ) ايضا الكود الخاص بتوزيع الملاحظة ( تم توليده بالذكاء الاصطناعى ) قمت بتجربته يعمل بشكل جيد قمت بتنسيق الملف وضبطه واضافة بعد الخصائص البسيطة والجمالية له الملف يتسع لـ ( 50 ) لجنة موزعة على كشفان عدد ايام امتحان ( 30 يوم ) به ايضا كشاف اللجان لكنه لا يوجد به حفظ الملف PDF ايضا كتابة التاريخ واليوم واسم المادة والزمن يدوى بعد الطباعة ( او قبل الطباعة ) اتمنى ان يقدم لك ما تريد الملف توزيع الملاحظين على اللجان2025_جديد.rar

استاذى الجليل و معلمى القدير و والدى الحبيب الاستاذ @ابوخليل أهديكم هذا المرفق يحتوى على الساعتين الرقمية والعقارب وبدون حدث الوقت وبه هديه لتعيير ثيم النموذج كذلك AnalogClock Without Timer Event.zip

نفس الإستعلام الخاص بك ، ولكني استخدمت شرط الفلترة في حدث عند الفتح للتقرير ليتوافق مع شرط الفلترة في الاستعلام لتطابق النتائج بينهما .. Private Sub Report_Open(Cancel As Integer) If Not IsNull(Forms!search4!searchtext.Value) Then Me.Filter = "[id] & ' ' & [rank] & ' ' & [emp] & ' ' & [employer] & ' ' & [emp_id] & ' ' & [national id] & ' ' & [date of birth] & ' ' & [phone] & ' ' & [phone next] & ' ' & [address] & ' ' & [notes] & ' ' & [marital status] & ' ' & [promote to] & ' ' & [promote date] & ' ' & [transfer to] & ' ' & [transfer date] & ' ' & [membership no] & ' ' & [establishment fee] & ' ' & [monthly installment] & ' ' & [subscription date] & ' ' & [age at subscription] & ' ' & [subscription daration] & ' ' & [due date] & ' ' & [membrship type] & ' ' & [created_date] & ' ' & [user] & ' ' & [mostafed] & ' ' & [national id2] & ' ' & [phone2] & ' ' & [sabb] & ' ' & [tarekh] & ' ' & [shek] & ' ' & [mostfad mn alaml] LIKE '*" & Replace(Forms!search4!searchtext.Value, "'", "''") & "*'" Me.FilterOn = True Else Me.Filter = "" Me.FilterOn = False End If End Sub

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

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

وعليكم السلام ورحمة الله تعالى وبركاته استاذى الجليل و معلمى القدير و والدى الحبيب الكود التالى فى وحده نمطية عامة Option Compare Database Option Explicit #If VBA7 Then Private Declare PtrSafe Function SetTimer Lib "user32" _ (ByVal hWnd As LongPtr, ByVal nIDEvent As LongPtr, _ ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As LongPtr Private Declare PtrSafe Function KillTimer Lib "user32" _ (ByVal hWnd As LongPtr, ByVal nIDEvent As LongPtr) As Long #Else Private Declare Function SetTimer Lib "user32" _ (ByVal hWnd As Long, ByVal nIDEvent As Long, _ ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long Private Declare Function KillTimer Lib "user32" _ (ByVal hWnd As Long, ByVal nIDEvent As Long) As Long #End If Private lngTimerID As LongPtr Private frmTargetClock As Form Public Sub StartSystemClock(frm As Form) Set frmTargetClock = frm lngTimerID = SetTimer(0, 0, 1000, AddressOf TimerProc) End Sub Public Sub StopSystemClock() If lngTimerID <> 0 Then KillTimer 0, lngTimerID lngTimerID = 0 End If End Sub Private Sub TimerProc(ByVal hWnd As LongPtr, ByVal uMsg As Long, ByVal idEvent As LongPtr, ByVal dwTime As Long) If Not frmTargetClock Is Nothing Then frmTargetClock!lblClock.Caption = Format(Now, "hh:nn:ss AM/PM") Else StopSystemClock End If End Sub الاحدات فى النموذج Option Compare Database Option Explicit Private Sub Form_Load() Call StartSystemClock(Me) End Sub Private Sub Form_Unload(Cancel As Integer) Call StopSystemClock End Sub المرفق Clock Without Timer Event.accdb

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

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

السلام عليكم المطلوب كما في العنوان Database1.accdb

تمام الله ينور على حضرتك ويجازيك خير ما فعلت ممكن تشرحلى عملتها ازاي ويبقى كتر خيرك وشكرا

استخدم التنسيق الشرطي .... افضل .... انظر

وعليكم السلام ورحمة الله و بركاته Sub PrintOrExportPDF_CustomRanges() Dim ws As Worksheet Dim rngAddress As String Dim sheetNames As Variant Dim printableSheetNames() As String Dim i As Integer, count As Integer Dim printChoice As VbMsgBoxResult Dim savePath As String Dim fileName As String ' أسماء الأوراق (عدّل حسب أوراقك) sheetNames = Array("Sheet1", "Sheet2", "Sheet3", "Sheet4") count = 0 ' سؤال المستخدم: طباعة أم PDF؟ printChoice = MsgBox("هل ترغب في طباعة الأوراق؟" & vbCrLf & "اضغط 'نعم' للطباعة، 'لا' لحفظ كـ PDF.", vbYesNoCancel + vbQuestion, "اختيار نوع الإخراج") If printChoice = vbCancel Then MsgBox "تم إلغاء العملية.", vbExclamation Exit Sub End If Application.ScreenUpdating = False ' تحديد النطاقات For i = LBound(sheetNames) To UBound(sheetNames) Set ws = ThisWorkbook.Sheets(sheetNames(i)) rngAddress = InputBox("أدخل النطاق المطلوب طباعته من الورقة: " & sheetNames(i), "تحديد نطاق الطباعة") If rngAddress <> "" Then On Error Resume Next ws.PageSetup.PrintArea = rngAddress If Err.Number = 0 Then count = count + 1 ReDim Preserve printableSheetNames(1 To count) printableSheetNames(count) = ws.Name End If On Error GoTo 0 Else MsgBox "تم تخطي الورقة: " & sheetNames(i), vbInformation End If Next i ' تنفيذ العملية حسب الاختيار If count > 0 Then If printChoice = vbYes Then ' ? طباعة مباشرة Sheets(printableSheetNames).PrintOut MsgBox "تمت طباعة الأوراق المحددة بنجاح.", vbInformation ElseIf printChoice = vbNo Then ' ? تصدير كـ PDF (بمصنف مؤقت) With Application.FileDialog(msoFileDialogFolderPicker) .Title = "اختر المجلد لحفظ ملف PDF" If .Show <> -1 Then MsgBox "لم يتم اختيار مجلد.", vbExclamation Exit Sub End If savePath = .SelectedItems(1) End With fileName = InputBox("أدخل اسم ملف PDF بدون .pdf", "اسم الملف") If fileName = "" Then MsgBox "لم يتم إدخال اسم الملف.", vbExclamation Exit Sub End If ' إنشاء مصنف مؤقت Dim tempBook As Workbook Set tempBook = Workbooks.Add ' نسخ الأوراق للمصنف المؤقت For i = 1 To count ThisWorkbook.Sheets(printableSheetNames(i)).Copy After:=tempBook.Sheets(tempBook.Sheets.count) Next i ' حذف الورقة الافتراضية الفارغة Application.DisplayAlerts = False Do While tempBook.Sheets.count > count tempBook.Sheets(1).Delete Loop Application.DisplayAlerts = True ' حفظ كـ PDF tempBook.ExportAsFixedFormat _ Type:=xlTypePDF, _ fileName:=savePath & "\" & fileName & ".pdf", _ Quality:=xlQualityStandard, _ IncludeDocProperties:=True, _ IgnorePrintAreas:=False, _ OpenAfterPublish:=True ' إغلاق المصنف المؤقت بدون حفظ tempBook.Close SaveChanges:=False MsgBox "تم حفظ ملف PDF بنجاح.", vbInformation End If Else MsgBox "لم يتم تحديد أي ورقة للطباعة أو التصدير.", vbExclamation End If Application.ScreenUpdating = True End Sub

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

Up up upاين الردود ؟؟؟؟

عمر ضاحى بارك الله فيك اخي الكريم ولكن بعد ربط وتظبيط الكود لم تاتي لي النتيجه تم التعديل على هذا المرفق ولم تنجح معي ABDatabase.rar

السلام عليكم جرب هذا الحل المعدات v3.xlsx

هذه فكرة بسيطة .. Foksh.accdb

السلام عليكم .. ممكن كود او معادلة يقوم بإظهار نتائج الغياب اليومي والشهري للموظفين .. الشرح داخل المصنف جزاكم الله خيرا موقف غياب موظفين.xlsm

مداخله بعد اذن الاستاذ فادي ^_^ ما تم هو اضافة هذه الجملة قبل جملة الاستعلام لكل قائمة SELECT "<الكل>" AS Odb_NoAcc FROM Table_ALLcauct UNION لتصبح هكذا (كمثال) SELECT "<الكل>" AS Odb_NoAcc FROM Table_ALLcauct UNION SELECT Odb_NoAcc FROM Table_ALLcauct GROUP BY Odb_NoAcc; اتمنا يكون هذا ما تريد ABDatabase.rar

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

Up