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

وعليكم السلام ورحمة الله وبركاته .. معلمنا الفاضل ، أسعد الله مسائك . قد مررت بهذا السؤال مسبقاً وكنت لا أعلم سببه ، ولكني اكتشفت السبب بالصدفة 😅 موضحاً في الصورة التالية :- وأعتقد أن السبب في هذا يعود الى أن الجداول مرتبطة بـ SQL Server أو قاعدة بيانات خارجية . والمرجح عندي سابقاً لأنني كنت أقوم بتثبيت نسختين من أوفيس ( 64 بلإصدار أعلى = 2019 ، و 32 بإصدار 2010 ) فقد يكون هو أحد الأسباب . مع أنني غير متأكد من الإحتمال الثاني حقيقةً . هذا والله أعلم

لحضرتكم بعض الارقام للعمل لوحه المفاتيح مفاتيح الأسهم KeyCode = 37 ' السهم لليسار ← KeyCode = 38 ' السهم للأعلى ↑ KeyCode = 39 ' السهم لليمين → KeyCode = 40 ' السهم للأسفل ↓ مفاتيح الوظائف KeyCode = 112 ' F1 KeyCode = 113 ' F2 KeyCode = 114 ' F3 KeyCode = 115 ' F4 KeyCode = 116 ' F5 KeyCode = 117 ' F6 KeyCode = 118 ' F7 KeyCode = 119 ' F8 KeyCode = 120 ' F9 KeyCode = 121 ' F10 KeyCode = 122 ' F11 KeyCode = 123 ' F12 مفاتيح التحكم KeyCode = 27 ' ESC KeyCode = 13 ' Enter KeyCode = 32 ' Space KeyCode = 9 ' Tab KeyCode = 8 ' Backspace KeyCode = 46 ' Delete KeyCode = 36 ' Home KeyCode = 35 ' End KeyCode = 33 ' Page Up KeyCode = 34 ' Page Down KeyCode = 45 ' Insert مفاتيح الأرقام KeyCode = 48 ' 0 KeyCode = 49 ' 1 KeyCode = 50 ' 2 KeyCode = 51 ' 3 KeyCode = 52 ' 4 KeyCode = 53 ' 5 KeyCode = 54 ' 6 KeyCode = 55 ' 7 KeyCode = 56 ' 8 KeyCode = 57 ' 9

واليك طريقه اخري بالكود Private Sub Worksheet_Change(ByVal Target As Range) Dim ws1 As Worksheet, ws2 As Worksheet Dim rng1 As Range, rng2 As Range Dim cell As Range Dim newValue As String ' تأكد أن التغيير حدث في العمود A (العمود 1) If Target.Column <> 1 Then Exit Sub If Target.Cells.Count > 1 Then Exit Sub ' تجنب اللصق الجماعي If IsEmpty(Target) Then Exit Sub Application.EnableEvents = False ' لمنع تشغيل الحدث مرارًا newValue = CStr(Target.Value) ' تحديد الأوراق Set ws1 = ThisWorkbook.Sheets("Sheet1") Set ws2 = ThisWorkbook.Sheets("Sheet2") ' تحديد النطاقات (نأخذ من A2 إلى آخر خلية غير فارغة) Set rng1 = ws1.Range("A2:A" & ws1.Cells(ws1.Rows.Count, "A").End(xlUp).Row) Set rng2 = ws2.Range("A2:A" & ws2.Cells(ws2.Rows.Count, "A").End(xlUp).Row) ' التحقق من التكرار في ورقة1 (باستثناء الخلية الحالية) For Each cell In rng1 If cell.Address <> Target.Address And cell.Value = newValue Then MsgBox "القيمة '" & newValue & "' موجودة مسبقًا في " & ws1.Name & "!", vbExclamation Target.ClearContents GoTo Cleanup End If Next cell ' التحقق من التكرار في ورقة2 For Each cell In rng2 If cell.Value = newValue Then MsgBox "القيمة '" & newValue & "' موجودة مسبقًا في " & ws2.Name & "!", vbExclamation Target.ClearContents GoTo Cleanup End If Next cell Cleanup: Application.EnableEvents = True End Sub طريقه اخري ب الكود.xlsm

وعليكم السلام ورحمه الله جرب الكود التالي لعله يفي بالغرض Private Sub UserForm_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer) If KeyCode = 27 Then ' 27 is the key code for Escape Unload Me End If End Sub Book1.xlsm

مرفق لك المثال بعد إضافة التقرير Database1.rar

وعليكم السلام ورحمة الله وبركاته .. إن شاء الله الأمر يسير أخي الكريم . في حدث عند التغيير لمربع النص الخاص بالبحث = SearchText ، قم بتعديل الكود من :- Private Sub SearchText_Change() [FormSearch].Requery End Sub ليصبح كالتالي :- Private Sub SearchText_Change() [FormSearch].Requery Me.Total = DSum("Mount", "QSearch") Me.Total.Requery End Sub وإن شاء الله تظهر معك النتيجة كما تريد ، وهذا ملفك للتجربة برنامج مصروفات خاص 2007.zip

بعد اذن استاذنا العزيز / موسى @Moosak تعديل للنواتين . Option Compare Database Option Explicit #If VBA7 Then Private Declare PtrSafe Function CallNextHookEx Lib "user32" (ByVal hHook As LongPtr, _ ByVal ncode As Long, ByVal wParam As LongPtr, lParam As Any) As LongPtr Private Declare PtrSafe Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As LongPtr Private Declare PtrSafe Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" _ (ByVal idHook As Long, ByVal lpfn As LongPtr, ByVal hmod As LongPtr, _ ByVal dwThreadId As Long) As LongPtr Private Declare PtrSafe Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As LongPtr) As Long Private Declare PtrSafe Function SendDlgItemMessage Lib "user32" Alias "SendDlgItemMessageA" _ (ByVal hDlg As LongPtr, ByVal nIDDlgItem As Long, ByVal wMsg As Long, _ ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr Private Declare PtrSafe Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As LongPtr, _ ByVal lpClassName As String, _ ByVal nMaxCount As Long) As Long Private Declare PtrSafe Function GetCurrentThreadId Lib "kernel32" () As Long #Else Private Declare Function CallNextHookEx Lib "user32" (ByVal hHook As Long, _ ByVal ncode As Long, ByVal wParam As Long, lParam As Any) As Long Private Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As Long Private Declare Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" _ (ByVal idHook As Long, ByVal lpfn As Long, ByVal hmod As Long, _ ByVal dwThreadId As Long) As Long Private Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) As Long Private Declare Function SendDlgItemMessage Lib "user32" Alias "SendDlgItemMessageA" _ (ByVal hDlg As Long, ByVal nIDDlgItem As Long, ByVal wMsg As Long, _ ByVal wParam As Long, ByVal lParam As Long) As Long Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As Long, _ ByVal lpClassName As String, _ ByVal nMaxCount As Long) As Long Private Declare Function GetCurrentThreadId Lib "kernel32" () As Long #End If Private Const EM_SETPASSWORDCHAR = &HCC Private Const WH_CBT = 5 Private Const HCBT_ACTIVATE = 5 Private Const HC_ACTION = 0 #If VBA7 Then Private hHook As LongPtr #Else Private hHook As Long #End If

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