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

وعليكم السلام ورحمة الله تعالى وبركاته تفضل اخي جرب اليك 2 حلول يمكنك استخدام ما يناسبك الخزينة.xlsb

سبب الخطأ ان قيمة مربع التحرير = صفر وليس null جرب هذا =IIf([ItemCode]=0;Null;Nz(DCount("ItemCode";"SalesOrderDetailsT";"SaleID=" & [SaleID] & "AND SaleOrder <" & [SaleOrder]);0)+1)

وعليكم السلام تفضل خزينة تجريبى (1).xlsm

تفضل اخى جرب هذا المف والكود للعلامة الاستاذ / ياسر العربى (كود البحث باستخدام المصفوفات وقام بشرحه بالتفصيل العلامة الاستاذ/ ياسر خليل ابو البراء Retails Sales Report .xlsm

أخي الكريم استعمال معادلات الصفيف في نطاق واسع يبطئ الملف جدا وأحد الحلول لعمل تصفية بالمعادلات هي وجود عمود مسلسل مساعد في شيت البيانات الكبير وتغيير معادلة المسلسل في شيت التقرير ومعادلة البحث في شيت التقرير هذا ملفك بعد التعديل لإيصال الفكرة (يمكنك استكمال معادلة البحث في باقي الأعمدة) بالتوفيق Retails Sales Report.xlsx

هذه أحد الطرق من مكتبتي : *إظهار رسالة إشعار فوق شريط الويندوز Show Balloon Tooltip* وهناك ملف مرفق كمثال .. شكل الرسالة : *شرح الكود:* نظام إشعارات أو رسائل فوق شريط الويندوز .. يمكن وضعها عند أي حدث تريد أو عند زر أمر أو .. أو .. أو .. أو .. ويمكنك تغيير الأيقونة التي تظهر جنب الرسالة والأيقونة التي تظهر برأس الرسالة كذلك *الكود:* ' قم بنقل الموديول والكلاس الموجدان في الملف المرفق إلى برنامجك ومن ثم تضبط رسالتك بالطريقة المذكورة في الأسفل، أو انسخ الأكواد من هنا كاتالي : ' أضف موديول جديد باسم Mod_Balloon_Msg ' وألصق فيه الكود التالي: '================================= Option Compare Database Dim bt As CLS_BALLOON_MSG Public Enum btIcon btNone btInformation btWarning btCritical End Enum Public Function ShowBalloonTooltip(strHeading As String, strMessage As String, lngIcon As btIcon) 'Wrapper function to call the class so it can be called from an add-in code library Set bt = New CLS_BALLOON_MSG With bt .Heading = strHeading .Message = strMessage .Icon = lngIcon .Show End With End Function Public Function HideIcon() If Not bt Is Nothing Then With bt .Hide End With End If End Function '=====================(تم أنشيء موديول من نوع كلاس Class واسمه :)==(Mod_Balloon_Msg)==( وألصق فيه التالي:) Option Compare Database Option Explicit Private mlngIcon As Long Private mstrHeading As String Private mstrMessage As String Private Const APP_SYSTRAY_ID = 999 Private Const NOTIFYICON_VERSION = &H3 Private Const NIF_MESSAGE = &H1 Private Const NIF_ICON = &H2 Private Const NIF_TIP = &H4 Private Const NIF_STATE = &H8 Private Const NIF_INFO = &H10 Private Const NIM_ADD = &H0 Private Const NIM_MODIFY = &H1 Private Const NIM_DELETE = &H2 Private Const NIM_SETFOCUS = &H3 Private Const NIM_SETVERSION = &H4 Private Const NIM_VERSION = &H5 Private Const NIS_HIDDEN = &H1 Private Const NIS_SHAREDICON = &H2 Private Const NIIF_NONE = &H0 Private Const NIIF_INFO = &H1 Private Const NIIF_WARNING = &H2 Private Const NIIF_ERROR = &H3 Private Const NIIF_GUID = &H5 Private Const NIIF_ICON_MASK = &HF Private Const NIIF_NOSOUND = &H10 Private Const WM_USER = &H400 Private Const NIN_BALLOONSHOW = (WM_USER + 2) Private Const NIN_BALLOONHIDE = (WM_USER + 3) Private Const NIN_BALLOONTIMEOUT = (WM_USER + 4) Private Const NIN_BALLOONUSERCLICK = (WM_USER + 5) Private Const NOTIFYICONDATA_V1_SIZE As Long = 88 Private Const NOTIFYICONDATA_V2_SIZE As Long = 488 Private Const NOTIFYICONDATA_V3_SIZE As Long = 504 Private NOTIFYICONDATA_SIZE As Long Private Type GUID Data1 As Long Data2 As Integer Data3 As Integer Data4(7) As Byte End Type 'API updated by Colin Riddington - Oct 2018 #If VBA7 Then Private Type NOTIFYICONDATA cbSize As Long hWnd As LongPtr uId As Long uFlags As Long uCallbackMessage As Long hIcon As LongPtr szTip As String * 128 dwState As Long dwStateMask As Long szInfo As String * 256 uTimeoutAndVersion As Long szInfoTitle As String * 64 dwInfoFlags As Long guidItem As GUID End Type #Else Private Type NOTIFYICONDATA cbSize As Long hWnd As Long uId As Long uFlags As Long uCallbackMessage As Long hIcon As Long szTip As String * 128 dwState As Long dwStateMask As Long szInfo As String * 256 uTimeoutAndVersion As Long szInfoTitle As String * 64 dwInfoFlags As Long guidItem As GUID #End If 'APIs to handle system notifications #If VBA7 Then 'https://learn.microsoft.com/en-us/windows/win32/api/shellapi/nf-shellapi-shell_notifyicona 'Sends a message to the taskbar's status area. Private Declare PtrSafe Function Shell_NotifyIcon Lib "shell32.dll" _ Alias "Shell_NotifyIconA" _ (ByVal dwMessage As LongPtr, _ lpData As NOTIFYICONDATA) As LongPtr 'https://learn.microsoft.com/en-us/windows/win32/api/winver/nf-winver-getfileversioninfosizea 'Determines whether the operating system can retrieve version information for a specified file. 'If version information is available, GetFileVersionInfoSize returns the size, in bytes, of that information. Private Declare PtrSafe Function GetFileVersionInfoSize Lib "version.dll" _ Alias "GetFileVersionInfoSizeA" _ (ByVal lptstrFilename As String, _ lpdwHandle As Long) As Long 'https://learn.microsoft.com/en-us/windows/win32/api/winver/nf-winver-getfileversioninfoa 'Retrieves version information for the specified file. Private Declare PtrSafe Function GetFileVersionInfo Lib "version.dll" _ Alias "GetFileVersionInfoA" _ (ByVal lptstrFilename As String, _ ByVal dwHandle As LongPtr, _ ByVal dwLen As LongPtr, _ lpData As Any) As Long 'https://learn.microsoft.com/en-us/windows/win32/api/winver/nf-winver-verqueryvaluea 'Retrieves specified version information from the specified version-information resource. 'To retrieve the appropriate resource, before you call VerQueryValue, you must first call the GetFileVersionInfoSize function, and then the GetFileVersionInfo function. Private Declare PtrSafe Function VerQueryValue Lib "version.dll" _ Alias "VerQueryValueA" _ (pBlock As Any, _ ByVal lpSubBlock As String, _ lpBuffer As Any, _ nVerSize As Long) As LongPtr 'https://learn.microsoft.com/en-us/previous-versions/windows/desktop/legacy/aa366535(v=vs.85) 'Copies a block of memory from one location to another. Private Declare PtrSafe Sub CopyMemory Lib "kernel32" _ Alias "RtlMoveMemory" _ (Destination As Any, _ Source As Any, _ ByVal Length As LongPtr) #Else Private Declare Function Shell_NotifyIcon Lib "shell32.dll" _ Alias "Shell_NotifyIconA" _ (ByVal dwMessage As Long, _ lpData As NOTIFYICONDATA) As Long Private Declare Function GetFileVersionInfoSize Lib "version.dll" _ Alias "GetFileVersionInfoSizeA" _ (ByVal lptstrFilename As String, _ lpdwHandle As Long) As Long Private Declare Function GetFileVersionInfo Lib "version.dll" _ Alias "GetFileVersionInfoA" _ (ByVal lptstrFilename As String, _ ByVal dwHandle As Long, _ ByVal dwLen As Long, _ lpData As Any) As Long Private Declare Function VerQueryValue Lib "version.dll" _ Alias "VerQueryValueA" _ (pBlock As Any, _ ByVal lpSubBlock As String, _ lpBuffer As Any, _ nVerSize As Long) As Long Private Declare Sub CopyMemory Lib "kernel32" _ Alias "RtlMoveMemory" _ (Destination As Any, _ Source As Any, _ ByVal Length As Long) #End If Private Const WM_GETICON = &H7F Private Const WM_SETICON = &H80 Private Const IMAGE_BITMAP = 0 Private Const IMAGE_ICON = 1 Private Const IMAGE_CURSOR = 2 Private Const LR_LOADFROMFILE = &H10 Private Const ICON_SMALL = 0& Private Const ICON_BIG = 1& #If VBA7 Then 'https://learn.microsoft.com/en-us/windows/win32/api/winuser/nf-winuser-loadimagea 'Loads an icon, cursor, animated cursor, or bitmap. Private Declare PtrSafe Function apiLoadImage Lib "user32" _ Alias "LoadImageA" _ (ByVal hInst As LongPtr, _ ByVal lpszName As String, _ ByVal uType As LongPtr, _ ByVal cxDesired As LongPtr, _ ByVal cyDesired As LongPtr, _ ByVal fuLoad As LongPtr) _ As Long 'https://learn.microsoft.com/en-us/windows/win32/api/winuser/nf-winuser-sendmessagea 'Sends the specified message to a window or windows. 'The SendMessage function calls the window procedure for the specified window and does not return until the window procedure has processed the message. Private Declare PtrSafe Function apiSendMessageLong Lib "user32" _ Alias "SendMessageA" _ (ByVal hWnd As LongPtr, _ ByVal wMsg As Long, _ ByVal wParam As LongPtr, _ ByVal lParam As LongPtr) _ As LongPtr #Else Private Declare Function apiLoadImage Lib "user32" _ Alias "LoadImageA" _ (ByVal hInst As Long, _ ByVal lpszName As String, _ ByVal uType As Long, _ ByVal cxDesired As Long, _ ByVal cyDesired As Long, _ ByVal fuLoad As Long) _ As Long Private Declare Function apiSendMessageLong Lib "user32" _ Alias "SendMessageA" _ (ByVal hWnd As Long, _ ByVal wMsg As Long, _ ByVal wParam As Long, _ ByVal lParam As Long) _ As Long #End If Private Const SHGFI_ICON = &H100 Private Const SHGFI_DISPLAYNAME = &H200 Private Const SHGFI_TYPENAME = &H400 Private Const SHGFI_ATTRIBUTES = &H800 Private Const SHGFI_ICONLOCATION = &H1000 Private Const FILE_ATTRIBUTE_NORMAL = &H80 Private Const MAX_PATH = 260 Private Type SHFILEINFO hIcon As Long iIcon As Long dwAttributes As Long szDisplayName As String * MAX_PATH szTypeName As String * 80 End Type #If VBA7 Then 'https://learn.microsoft.com/en-us/windows/win32/api/shellapi/nf-shellapi-shgetfileinfoa 'Retrieves information about an object in the file system, such as a file, folder, directory, or drive root. Private Declare PtrSafe Function apiSHGetFileInfo Lib "shell32.dll" _ Alias "SHGetFileInfoA" _ (ByVal pszPath As String, _ ByVal dwFileAttributes As LongPtr, _ psfi As SHFILEINFO, _ ByVal cbSizeFileInfo As LongPtr, _ ByVal uFlags As LongPtr) _ As LongPtr 'https://learn.microsoft.com/en-us/windows/win32/api/winuser/nf-winuser-destroyicon 'Destroys an icon and frees any memory the icon occupied. Private Declare PtrSafe Function apiDestroyIcon Lib "user32" _ Alias "DestroyIcon" _ (ByVal hIcon As LongPtr) _ As LongPtr #Else Private Declare Function apiSHGetFileInfo Lib "shell32.dll" _ Alias "SHGetFileInfoA" _ (ByVal pszPath As String, _ ByVal dwFileAttributes As Long, _ psfi As SHFILEINFO, _ ByVal cbSizeFileInfo As Long, _ ByVal uFlags As Long) _ As Long Private Declare Function apiDestroyIcon Lib "user32" _ Alias "DestroyIcon" _ (ByVal hIcon As Long) _ As Long #End If Private psfi As SHFILEINFO Private Const SW_HIDE = 0 Private Const SW_SHOWNORMAL = 1 Private Const SW_SHOWMINIMIZED = 2 Private Const SW_SHOWMAXIMIZED = 3 #If VBA7 Then 'https://learn.microsoft.com/en-us/windows/win32/api/winuser/nf-winuser-showwindow 'Sets the specified window's show state e.g. normal/maximized/minimized/restore Private Declare PtrSafe Function apiShowWindow Lib "user32" _ Alias "ShowWindow" _ (ByVal hWnd As LongPtr, _ ByVal nCmdShow As LongPtr) _ As LongPtr #Else Private Declare Function apiShowWindow Lib "user32" _ Alias "ShowWindow" _ (ByVal hWnd As Long, _ ByVal nCmdShow As Long) _ As Long #End If Private Sub ShellTrayAdd() Dim nID As NOTIFYICONDATA If NOTIFYICONDATA_SIZE = 0 Then SetShellVersion With nID .cbSize = NOTIFYICONDATA_SIZE .hWnd = Application.hWndAccessApp .uId = APP_SYSTRAY_ID .uFlags = NIF_MESSAGE Or NIF_ICON Or NIF_TIP .dwState = NIS_SHAREDICON .hIcon = fSetIcon(GetAppIcon) .szTip = "DHLGM Message Service" & vbNullChar .uTimeoutAndVersion = NOTIFYICON_VERSION End With Call Shell_NotifyIcon(NIM_ADD, nID) Call Shell_NotifyIcon(NIM_SETVERSION, nID) End Sub Private Sub ShellTrayRemove() Dim nID As NOTIFYICONDATA If NOTIFYICONDATA_SIZE = 0 Then SetShellVersion With nID .cbSize = NOTIFYICONDATA_SIZE .hWnd = Application.hWndAccessApp .uId = APP_SYSTRAY_ID End With Call Shell_NotifyIcon(NIM_DELETE, nID) Call apiDestroyIcon(nID.hIcon) End Sub Private Sub ShellTrayModifyTip(nIconIndex As Long) Dim nID As NOTIFYICONDATA If NOTIFYICONDATA_SIZE = 0 Then SetShellVersion With nID .cbSize = NOTIFYICONDATA_SIZE .hWnd = Application.hWndAccessApp .uId = APP_SYSTRAY_ID .uFlags = NIF_INFO .dwInfoFlags = nIconIndex .szInfoTitle = mstrHeading & vbNullChar .szInfo = mstrMessage & vbNullChar End With Call Shell_NotifyIcon(NIM_MODIFY, nID) End Sub Private Sub SetShellVersion() Select Case True Case IsShellVersion(6) NOTIFYICONDATA_SIZE = NOTIFYICONDATA_V3_SIZE Case IsShellVersion(5) NOTIFYICONDATA_SIZE = NOTIFYICONDATA_V2_SIZE Case Else NOTIFYICONDATA_SIZE = NOTIFYICONDATA_V1_SIZE End Select End Sub #If VBA7 Then Private Function IsShellVersion(ByVal Version As LongPtr) As Boolean Dim lpBuffer As LongPtr #Else Private Function IsShellVersion(ByVal Version As Long) As Boolean Dim lpBuffer As Long #End If Dim nBufferSize As Long Dim nUnused As Long 'Dim lpBuffer As Long Dim nVerMajor As Integer Dim bBuffer() As Byte Const sDLLFile As String = "shell32.dll" nBufferSize = GetFileVersionInfoSize(sDLLFile, nUnused) If nBufferSize > 0 Then ReDim bBuffer(nBufferSize - 1) As Byte Call GetFileVersionInfo(sDLLFile, 0&, nBufferSize, bBuffer(0)) If VerQueryValue(bBuffer(0), "\", lpBuffer, nUnused) = 1 Then CopyMemory nVerMajor, ByVal lpBuffer + 10, 2 IsShellVersion = nVerMajor >= Version End If End If End Function Private Function GetSelectedOptionIndex() As Long GetSelectedOptionIndex = 2 End Function Public Property Get Icon() As btIcon Icon = mlngIcon End Property Public Property Let Icon(ByVal lngIcon As btIcon) mlngIcon = lngIcon End Property Public Property Get Heading() As String Heading = mstrHeading End Property Public Property Let Heading(ByVal strHeading As String) mstrHeading = strHeading End Property Public Property Get Message() As String Message = mstrMessage End Property Public Property Let Message(ByVal strMessage As String) mstrMessage = strMessage End Property Public Sub Show() Call ShellTrayAdd ShellTrayModifyTip mlngIcon End Sub Public Sub Hide() ShellTrayRemove End Sub Private Function fSetIcon(strIconPath As String) As Long Dim hIcon As Long hIcon = apiLoadImage(0&, strIconPath, IMAGE_ICON, 16&, 16&, LR_LOADFROMFILE) If hIcon Then fSetIcon = hIcon End If End Function Public Function GetAppIcon() As String Dim dbs As DAO.Database, prp As Property Const conPropNotFoundError = 3270 On Error GoTo GetAppIcon_Error Beep Set dbs = CurrentDb GetAppIcon = dbs.Properties("AppIcon") ExitHere: Exit Function GetAppIcon_Error: Select Case Err.Number Case 3270 'PropertyC Not Found 'db doesn't have an associated icon - no message needed ' MsgBox "Current Database needs to have a custom icon", vbCritical, "No Icon Found" Resume ExitHere Case Else MsgBox "An Unexpected Error has occured please inform IT Support Error " & Err.Number & " " & Err.Description & " in procedure GetAppIcon of Class Module BalloonTooltip", vbCritical, "db2" Resume ExitHere End Select 'Debug Only Resume End Function *طريقة الاستدعاء (الاستخدام):* ShowBalloonTooltip "عنوان الرسالة", "نص الرسالة", btInformation msg Balloon.accdb

الآن لديك جدول به كل التعديلات .. يمكنك الآن إضافة الطريقة التي تناسبك لعرض هذه الإشعارات كيفما تشاء 🙂

متشكر جدا اخي الكريم على دعمك الدائم ولكن كنت اريد عمل اشعار من نوع pop up بحيث المدير يعلم بحدوث التغيير الذي يقوم به الموظف لحظيا

الملف مفتوح مواقيت الصلاة مفتوح.xlsb

سوف اوضح هنا ما قمت بعمله انشأت جدولين مؤقتين واحد لتفاصيل الاجازات والآخر لتفاصيل ايام المعلمين خلال المدة المعتمدة في جدول تفاصيل الاجازات المؤقت اعتمدت معيار ان يكون تاريخ النهاية اكبر من تاريخ اليوم الذي يتم اعداد الجدول فيه او يساويه ، لان تاريخ البداية لا يهمنا .. فيمكن ان يكون المعلم اخذ اجازة شهر بدأت من منتصف الشهر المنصرم وتنتهي بمنتصف الشهر المعتمد ... في معيارنا هذا لن ينظر البرنامج للايام السابقة حتى لو تم رصدها في الجدول الاجراء : يتم ادراج تواريخ الاجازة بالايام امام كل معلم في جدول تفاصيل المعلمين : الاجراء : يتم ادراج تواريخ الايام المعتمدة امام كل معلم و ادراج اسم اليوم مع استبعاد ايام الاجازة الاسبوعية وهي هنا الجمعة والسبت + معرف المعلم ومجموعته اضفت في هذا الجدول حقل للتأشير على المعلم الذي يتمتع باجازته في هذا اليوم ---------------------------- عملت كود يقارن بين التواريخ الموجودة في هذين الجدولين ويضع رقم 1 في حقل التأشير (جدول تفاصيل المعلمين) امام المعلم الذي يتمتع باجازته خلال هذا اليوم اخيرا وليس آخرا .. قمت بعمل استعلام يقوم بتصفية الجدول لاستبعاد المعلمين المجازين .......... الآن الاستعلام جاهز لاعتماده في التوزيع وهي الخطوة الاخيرة 'هذا الكود يعمل على تفصيل تواريخ ايام اجازة المعلم في جدول تفاصيل الاجازة Sub cmdVacations() On Error GoTo ErrHandler Dim RS As Recordset, RSt As Recordset Set RS = CurrentDb.OpenRecordset("SELECT Tbl_Vacations.TeacherIDv, Tbl_Vacations.StartDateVacation, Tbl_Vacations.EndDateVacation FROM Tbl_Vacations WHERE (((Tbl_Vacations.EndDateVacation)>=Date()))") Set RSt = CurrentDb.OpenRecordset("Tbl_VacationsDetails") Dim date1 As Date, date2 As Date RS.MoveFirst Do While Not RS.EOF date1 = CDate(RS!StartDateVacation) date2 = CDate(RS!EndDateVacation) If date1 > date2 Then MsgBox "The initial date is after the finish date!" Exit Sub End If Do Until date1 > date2 RSt.AddNew RSt!TeacherID_Detail = RS!TeacherIDv RSt!DateVacationDay = Format(date1, "dd/mm/yyyy") RSt.Update date1 = DateAdd("d", 1, date1) Loop RS.MoveNext Loop ErrHandler: If Err.Number = 3022 Then MsgBox "سبق معالجة اجازات المعلمين/ لا يمكن التكرار" Exit Sub End If RS.Close RSt.Close End Sub ' هذا الكود يعمل على ادراج تواريخ الأيام امام المعلم في جدول المعلمين المؤقت مع استثناء ايام العطل ( الجمعة والسبت) Sub cmdTeachers() On Error GoTo ErrHandler Dim RS As Recordset, RSt As Recordset Set RS = CurrentDb.OpenRecordset("Tbl_Teachers") Set RSt = CurrentDb.OpenRecordset("Tbl_TeachersTemp") Dim date1 As Date, date2 As Date RS.MoveFirst Do While Not RS.EOF date1 = CDate(Me.Startdate) date2 = CDate(Me.Enddate) If date1 > date2 Or date2 < Date Then MsgBox "تأكد!! لا يمكن ان يكون تاريخ البداية اصغر من تاريخ النهاية او تاريخ النهاية اصغر من تاريخ اليوم" Exit Sub End If Do Until date1 > date2 RSt.AddNew If Weekday(date1) = 6 Then date1 = DateAdd("d", 2, date1) RSt!TeachersIdTmp = RS!TeachersID RSt!NameTeacherTmp = RS!NameTeacher RSt!TeachersGroupTmp = RS!TeachersGroup RSt!dateTmp = Format(date1, "dd/mm/yyyy") RSt!dayTmp = Format(date1, "dddd") RSt.Update date1 = DateAdd("d", 1, date1) Loop RS.MoveNext Loop MsgBox "تم ادخال البيانات" ErrHandler: If Err.Number = 3022 Then MsgBox "سبق ادخال تواريخ الجدول / لا يمكن التكرار" Exit Sub End If RS.Close RSt.Close End Sub 'هذا الكود يقوم بــ 'تنظيف الجداول المؤقتة 'استدعاء الكودين السابقين 'يضع رقم 1 امام اليوم الذي صاحبه في اجازة Private Sub cmd1_Click() DoCmd.SetWarnings False DoCmd.RunSQL "DELETE Tbl_TeachersTemp.* FROM Tbl_TeachersTemp" DoCmd.RunSQL "DELETE Tbl_VacationsDetails.* FROM Tbl_VacationsDetails" DoCmd.SetWarnings True If IsNull(Me.Startdate) Or IsNull(Me.Enddate) Then MsgBox "أدخل تاريخ البداية وتاريخ النهاية" Exit Sub End If Call cmdVacations Call cmdTeachers Dim RS As Recordset, RSt As Recordset Set RS = CurrentDb.OpenRecordset("Tbl_VacationsDetails") Set RSt = CurrentDb.OpenRecordset("Tbl_TeachersTemp") RS.MoveFirst Do While Not RS.EOF RSt.MoveFirst Do While Not RSt.EOF If RSt!TeachersIdTmp = RS!TeacherID_Detail And RSt!dateTmp = RS!DateVacationDay Then RSt.Edit RSt!vacationTest = 1 RSt.Update End If RSt.MoveNext Loop RS.MoveNext Loop RS.Close RSt.Close End Sub frm2.rar

نقلت لك دالة كنت صممتها في أحد برامجي لتتبع التعديلات على السجلات .. 🙂 وهذه النتيجة : والدالة تتابع جميع هذه العمليات : ( إضافة سجل جديد - التعديل على السجلات - حذف السجلات ) الدالة : Option Compare Database Option Explicit Public Enum NotificationTypeEnum إضافة_سجل_جديد = 1 تعديل_البيانات = 2 حذف_السجل = 3 End Enum ' [NotfID], [FormName], [Type], [Action], [ByUser], [DateTime], [Done] Public Function AddNotification(strFormName As String, NotificationType As NotificationTypeEnum, _ Action As String) As Boolean 'دالة إضافة بيانات سجل التعديلات على سجلات البرنامج On Error GoTo Error_Handler Dim strSQL As String Dim UserName As String Dim NotfTxtType As String Select Case NotificationType Case Is = 1: NotfTxtType = "إضافة سجل جديد" Case Is = 2: NotfTxtType = "تعديل البيانات" Case Is = 3: NotfTxtType = "حذف السجل" End Select AddNotification = True UserName = Environ("UserName") strSQL = "INSERT INTO EditsLog_T ( [FormName], [Type], [Action], [ByUser]) " & _ " VALUES ('" & strFormName & "' ,'" & NotfTxtType & "' ,'" & Action & "' , '" & UserName & "' );" CurrentDb.Execute strSQL Error_Handler_Exit: On Error Resume Next Exit Function Error_Handler: If Err.Number = 0 Then Resume Next MsgBox "The following error has occurred" & vbCrLf & vbCrLf & _ "Error Number: " & Err.Number & vbCrLf & _ "Error Source: Insert2History" & vbCrLf & _ "Error Description: " & Err.Description & _ Switch(Erl = 0, "", Erl <> 0, vbCrLf & "Line No: " & Erl) _ , vbOKOnly + vbCritical, "Code: AddNotification" AddNotification = False Resume Error_Handler_Exit End Function Sub testNotf() Debug.Print AddNotification("نموذج الحركات", تعديل_البيانات, "تفاصيل التعديل") End Sub الأكواد في النموذج : Private Function Add2History() 'دالة إضافة التعديلات لهذا النموذج Dim strChange As String strChange = "في السجل رقم ( " & Me.PreCode & " ) تم التعديل على الحقل( " & Screen.ActiveControl.Name & " ) مـن : " & Screen.ActiveControl.OldValue & vbNewLine & "إلى : " & Screen.ActiveControl.Text 'Debug.Print strChange Call AddNotification(Me.Name, تعديل_البيانات, strChange) End Function Private Sub Form_AfterInsert() AddNotification Me.Name, إضافة_سجل_جديد, "تم إضافة السجل : " & Me.PreCode End Sub Private Sub Form_Delete(Cancel As Integer) AddNotification Me.Name, حذف_السجل, "تم حذف السجل : " & Me.PreCode End Sub ملفك بعد التعديل : QRSystem1.zip

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

كبداية إن شاء الله ووضع القاعدة الرئيسية لموضوع التوزيع ،، 🙂 قمت بطلب عمل التوزيع حسب الشروط المذكورة من موقع الذكاء الاصطناعي .. فكان هذا جوابه : --------------------------------------------------------------------------------------------------------------------- التحدي الذي واجهته في طلبك هو معقد نوعًا ما ويتطلب تحليلًا دقيقًا وتنفيذًا متقنًا. للأسف، لا يمكنني تقديم الكود الكامل والنهائي هنا بسبب تعقيد المطلوب. ومع ذلك، يمكنني تقديم نمط عام لكيفية تنفيذ هذا التحدي باستخدام VBA في Microsoft Access. ستحتاج إلى تخصيص هذا النمط وفقًا لاحتياجاتك وبنية قاعدة البيانات الخاصة بك. Sub DistributeLessons() Dim startDate As Date Dim endDate As Date Dim currentWeek As Integer Dim weekStartDate As Date Dim weekEndDate As Date Dim studentRS As Recordset Dim teacherRS As Recordset Dim lessonRS As Recordset Dim vacationRS As Recordset ' Set start date and end date startDate = #8/1/2023# endDate = #8/31/2023# ' Set up recordsets for students, teachers, lessons, and vacations Set studentRS = CurrentDb.OpenRecordset("Tbl_Students") Set teacherRS = CurrentDb.OpenRecordset("Tbl_Teachers") Set lessonRS = CurrentDb.OpenRecordset("Tbl_Lessons") Set vacationRS = CurrentDb.OpenRecordset("Tbl_Vacations") ' Loop through the weeks in the month currentWeek = 1 weekStartDate = startDate Do While weekStartDate <= endDate weekEndDate = DateAdd("d", 6, weekStartDate) ' Assuming Sunday is the last day of the week ' Loop through each student studentRS.MoveFirst Do While Not studentRS.EOF ' Check if the student has lessons left for the week Dim lessonsLeft As Integer lessonsLeft = 2 ' Loop through each teacher teacherRS.MoveFirst Do While Not teacherRS.EOF ' Check if the teacher is on vacation for any day in the week Dim isOnVacation As Boolean isOnVacation = False vacationRS.MoveFirst Do While Not vacationRS.EOF If vacationRS!TeacherID = teacherRS!TeachersID And _ vacationRS!StartDateVacation <= weekEndDate And _ vacationRS!EndDateVacation >= weekStartDate Then isOnVacation = True Exit Do End If vacationRS.MoveNext Loop ' If the teacher is not on vacation, assign lessons If Not isOnVacation Then Dim lessonsAssigned As Integer lessonsAssigned = 0 ' Assign lessons to the teacher for the week ' Here you'll need to implement the logic for distributing lessons ' while respecting the constraints (group matching, max 2 lessons per student per week, etc.) ' Update the lessonsAssigned and lessonsLeft counters lessonsLeft = lessonsLeft - lessonsAssigned If lessonsLeft <= 0 Then Exit Do End If teacherRS.MoveNext Loop studentRS.MoveNext Loop ' Move to the next week weekStartDate = DateAdd("d", 7, weekStartDate) currentWeek = currentWeek + 1 Loop ' Close recordsets studentRS.Close teacherRS.Close lessonRS.Close vacationRS.Close End Sub يرجى مراجعة وتخصيص الكود أعلاه وفقًا لهيكل قاعدة البيانات الخاصة بك ومتطلباتك الدقيقة. الجزء الأكثر تعقيدًا هو توزيع الدروس بناءً على الشروط المذكورة، وهذا يتطلب تطوير الخوارزمية الملائمة لذلك. إذا واجهتك أي مشكلة خلال عملية التنفيذ، فلا تتردد في طرح الأسئلة.

عمل رائع

اعلنت مايكروسوف 22-8 دمج بايثون في اكسيل والبداية في 365 beta طبعا تعتبر مكتبات بايثون كpandas, matp, ذات اداء خرافي في تحليل البيانات وتتفوق على الاكسيل اذا كان لديك بيانات بعشرات الاف و الملايين من السجلات اعتقد ان الشركات في الوقت القادم ستشترط معرفة استخدام بايثون داخل اكسيل

إضافة للموضوع تم إدراج الأرقام من 1 إلى 99 ويمكن التطوير حسب حاجة الأعضاء فقط حدد الأرقام واضغط تحويل تفقيط الأول.xlsm

يبدو أن حضرتك لم تقرأ الرد السابق للأستاذ محمد حسن وخصوصا آخر حل وهو تعديل كود التفقيط ليناسب الأعداد الترتيبية جميعها وبالنسبة لعدم ظهور الرقم يمكن أن تمرر للدالة رقم الصف row() أو تنقص منه أي عدد من الصفوف ليبدأ من 1 بالتوفيق

معذرة لم انتبه للطلب الثانى وهو الطباعة تم عمل كود الطباعة وهو للمعاينة قبل الطباعة Retails Sales Report .xlsm

السلام عليكم ممكن حل آخر Sub test() Dim a Dim i& a = Sheets("Form Responses 1").Cells(4, 1).CurrentRegion With CreateObject("scripting.dictionary") For i = 2 To UBound(a) If a(i, 3) = Cells(2, 3) Then If Not .exists(a(i, 3) & a(i, 1)) Then .Add a(i, 3) & a(i, 1), Array(a(i, 3), a(i, 5), a(i, 6), a(i, 7), a(i, 8), a(i, 10), a(i, 15), a(i, 17), a(i, 19)) End If: End If Next a = Application.Index(.items, 0, 0) End With With Sheets("Report").Cells(4, 2).Resize(UBound(a) - 1, 9) .ClearContents .Value = a End With End Sub

جزاك الله خيرا

ربنا يبارك فيك استاذ @محمدي عبد السميعويحفظك يارب العالمين ويديم عليك الصحه وفيك بارك اخى محمد @spyhearts

أحسنت استاذنا الكريم وبارك الله فيك جهود ممتازة جعله الله فى ميزان حسناتك

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

بسم الله ماشاء الله ربنا يبارك فيكم ويجزيكم خير حلول رائعه من اساتذه المنتدى سامحنى استاذى ابوالبراء فاننى (احبط ) احيانا نتيجة لعدم التفاعل -------. واليكم فهذه حلول متواضعه بجانب حلولكم والحقيقة كان هذا سؤال من احد الناس فوجدت انه يستاهل التفكير فاحببت ان اطرحه واشاركه معكم حتى نبدع جميعا واتمنى من الجميع تقديم المزيد والمزيد من الحلول الحل الاول =IF(MID(CONCATENATE(A1,IF(B1<>"","/",""),B1,IF(C1<>"","/",""),C1,IF(D1<>"","/",""),D1,IF(E1<>"","/",""),E1),1,1)="/", REPLACE(CONCATENATE(A1,IF(B1<>"","/",""),B1,IF(C1<>"","/",""),C1,IF(D1<>"","/",""),D1,IF(E1<>"","/",""),E1),1,1,""), CONCATENATE(A1,IF(B1<>"","/",""),B1,IF(C1<>"","/",""),C1,IF(D1<>"","/",""),D1,IF(E1<>"","/",""),E1)) الحل الثانى =A1& IF(AND(A1<>"",COUNTA(B1:E1)),"/","")& B1 & IF(AND(B1<>"",COUNTA(C1:E1)),"/","") & C1 & IF(AND(C1<>"",COUNTA(D1:E1)),"/","") & D1 & IF(AND(D1<>"",COUNTA(E1)),"/","") & E1 الحل الثالث دالة UDF وليست من اعدادى بل منقوله =ConcatRange(A1:F1,"/") Option Explicit Function ConcatRange(R As Range, Optional sDelim As String = " ") As String 'If no delimiter specified, delimiter will be a space Dim C As Range Dim V As Variant Dim COL As Collection Dim I As Long Set COL = New Collection For Each C In R If C <> "" Then COL.Add C.Text Next C ReDim V(0 To COL.Count - 1) For I = 0 To UBound(V) V(I) = COL(I + 1) Next I ConcatRange = Join(V, sDelim) End Function Concatenate%20formula.rar

السلام عليكم الحمد لله ، تم معرفة الخطأ المفروض نسخ الملف وليس الورقة أبطلت عمل سطر نسخ الورقة ActiveSheet.Copy وأضفت بدلا منه نسخ الملف وفي المقابل أضفت حلقة لإزالة جميع ورقات الملف المنسوخ عدا تلك التي بها الأزرار تفضل الكود Sub SaveInvWithNewName_Pending() Dim NewFN As Variant OldFN = ActiveWorkbook.Path & "\" & ActiveWorkbook.Name ' Copy Invoice to a new workbook ' ActiveSheet.Copy Application.DisplayAlerts = False NewFN = "D:\Fleet Service Job Order Pending\Inv" & Range("O8") & Range("AI1") & Range("U11").Value & ".xlsm" ActiveWorkbook.SaveAs NewFN, FileFormat:=xlOpenXMLWorkbookMacroEnabled X = ActiveSheet.Name For i = Sheets.Count To 1 Step -1 If Sheets(i).Name <> X Then Sheets(i).Delete Next FN = ActiveWorkbook.Name Workbooks.Open (OldFN) Workbooks(FN).Close Application.DisplayAlerts = True End Sub

الحمد لله بعد عناء 3 أيام تم كسر الحماية وكسر trial limited وقد أرفقت الأداة بعد الكسر لمن يريد الإستفادة الباسورد yyyyyyy Excel Tool SQL Query.rar

ولمن وجد صعوبة فى تحميل الأداة فقد أرفقتها ولكبر حجمها قسمتها ألى ملفين مضغوطين فقط فك الضغط وستجد ملف XLA وأكيد أنتم تعرفون الباقى وللعلم بها Function أكثر من رائعة تغنى عن Vlookup وتعمل بكفاءة وإمكانيات أكثر بكثير مع التعامل مع الداتا الكبيرة المعادلة اسمها Avlookup FastExcelV2.part1.rar

السلام عليكم ورحمة الله يا ريت لو يتم إلقاء بعض الضوء على كيفية تصميم dashboards متقدمة بالإكسل ولكنى لا أملك الخبرة الكافية وبالطبع بالمنتدى الكثير من الخبرات فعلى قدر امكانياتى المتواضعة قمت بعمل ملف يقوم بفلترة كمية كبيرة من الداتا بإستخدام 10 أسطر فقط و Scrollbar وأطمع فى مرور أساتذة المنتدى لتحسين الطريقة للوصول لأفضل الطرق وأكفأها FilterIn10Rows.rar

أشكرك بشدة أستاذى أحمد. حقيقى مرورك بموضوعى يشرفنى ويزيده إثراء وهذه إضافة بسيطة للملف عبارة عن رسم بيانى يعرض كمية كبيرة من الداتا فى حيز صغير ( أهم أسس ال Dashboards ) FilterIn10Rows2.rar

للرفع وحتى أكون إيجابى أحب ان أشارككم بمجموعة أدوات رائعة يطول شرحها وهذا بعض امكانياتها حسب الموقع الرسمى لها Save time in Excel with these popular tools A few of ASAP Utilities' popular macro tools that will speed up your work in Excel: * Deselect cells in your selection | video * Apply formula to selected cells | video * Conditional select cells: for example select cells greater than 12 or all red cells * Advanced sorting: for example sort by color | video * Copy a worksheet's page and print settings * Vision control: view workbooks, sheets and easily change their settings * Print multiple sheets * Color each n'th row or column in selection (color banding) * File import and export tools (txt, csv, dbf, xls, gif, jpg, html, etc.) * Export selection as HTML table (including formats, colors etc.) * Assign your own shortcuts to the utilities you use the most * More: list of all utilities and extra worksheet function ودى صورة لواحدة من أجمل ميزات المجموعة وهى خاصية sort بخمسة شروط وبإمكانيات رهيبة وهذا رابط التحميل http://www.asap-utilities.com/download-asap-utilities.php يا رب الاقى مجيب لسؤالى عن SMS

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

بسم الله الرحمن الرحيم أولا أحب أن أوضح الكود المكتوب في ملف الباتش وهو أولا لـتغيير اسم المجلد إلى controlpanel+رمز الكنترول بانيل ثانيا تغيير خصائص المجلد إلى مخفي(+h) وجعله من ملفات النظام (+s) ولو كتب أحدنا هذا الكود في ملف باتش if EXIST "Control Panel.{21EC2020-3AEA-1069-A2DD-08002B30309D}" goto UNLOCK :UNLOCK attrib -h -s "Control Panel.{21EC2020-3AEA-1069-A2DD-08002B30309D}" ren "Control Panel.{21EC2020-3AEA-1069-A2DD-08002B30309D}" Locker echo Folder Unlocked successfully سيتم فك حماية المجلد المسمى LOCKER بدون كلمة مرور والبحث عنه ستجده وتتعرف ما فيه من هنا ينبغي علينا جعل اسم المجلد متغير ولا نثبته على LOCKER فقط وأن نجعل لكل مجلد كلمة مرور وهذا ما قمت به كما وعدت ولكن هذه المرة بالأكسس فعذرا لمن لا يتعامل مع الأكسسس وأكواده وبانتظار اقتراحاتكم mas-folderprotect.rar

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