حمادة عمر

رووعة اخي واستاذي الحبيب / بن عليه جزاك الله خيرا

الاستاذ القدير / مجدي يونس نسألك الدعاء عن الحبيب المصطفي بصلاح الحال والدعاء لمصرنا الحبيب بصلاح الاحوال حج مبرور وذنب مغفور باذن الله تقبل تحياتي

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

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

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

الخطوات : 1- ضع هدا الكود في ThisWorkBook Module Option Explicit Private Sub Workbook_Open() Application.Goto ActiveSheet.Cells(1, 1), True End Sub Private Sub Workbook_BeforeClose(Cancel As Boolean) 'Safety measure in case hook still installed. Call UnHookValidationList Call Delay(2) 'two seconds. End Sub Private Sub Delay(sTime As Single) Dim t As Single t = Timer Do DoEvents Loop Until Timer - t >= sTime End Sub 2- ضع هدا الكود في Sheet Module ( موديول الصفحة الموجود فيها القائمة المنسدلة) Option Explicit Private Sub Worksheet_SelectionChange(ByVal Target As Range) If HasValidateList(Target) Then Call HookValidationList Else Call UnHookValidationList End If End Sub Private Function HasValidateList(Cell As Range) As Boolean On Error Resume Next HasValidateList = Cell.Validation.InCellDropdown End Function 3- و اخيرا هدا الكود في ( Standard Module) Option Explicit Private Declare Function FindWindow Lib "user32" _ Alias "FindWindowA" _ (ByVal lpClassName As String, _ ByVal lpWindowName As String) As Long Private Declare Function FindWindowEx Lib "user32" _ Alias "FindWindowExA" _ (ByVal hWnd1 As Long, _ ByVal hWnd2 As Long, _ ByVal lpsz1 As String, _ ByVal lpsz2 As String) As Long Private Declare Function GetCurrentThreadId Lib "kernel32" _ () As Long Private Declare Function GetWindowLong Lib "user32" _ Alias "GetWindowLongA" _ (ByVal hwnd As Long, _ ByVal nIndex 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 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 CallNextHookEx Lib "user32" _ (ByVal hHook As Long, _ ByVal nCode As Long, _ ByVal wParam As Long, _ lParam As Any) As Long Private Declare Function UnhookWindowsHookEx Lib "user32" _ (ByVal hHook As Long) As Long Private Declare Function SetWindowLong Lib "user32" _ Alias "SetWindowLongA" _ (ByVal hwnd As Long, _ ByVal nIndex As Long, _ ByVal dwNewLong As Long) As Long Private Declare Function CallWindowProc Lib "user32" _ Alias "CallWindowProcA" _ (ByVal lpPrevWndFunc As Long, _ ByVal hwnd As Long, _ ByVal Msg As Long, _ ByVal wParam As Long, _ ByVal lParam As Long) As Long Private Declare Function WindowFromPoint Lib "user32" _ (ByVal xPoint As Long, _ ByVal yPoint As Long) As Long Private Declare Function ShowWindow Lib "user32" _ (ByVal hwnd As Long, _ ByVal nCmdShow As Long) As Long Private Type POINTAPI X As Long Y As Long End Type Private Type MSLLHOOKSTRUCT pt As POINTAPI mouseData As Long flags As Long time As Long dwExtraInfo As Long End Type Private Const WH_CBT As Long = 5 Private Const HCBT_CREATEWND As Long = 3 Private Const HCBT_DESTROYWND As Long = 4 Private Const WH_MOUSE_LL As Long = 14 Private Const WM_MOUSEWHEEL As Long = &H20A Private Const HC_ACTION As Long = 0 Private Const GWL_HINSTANCE As Long = (-6) Private lCBTHook As Long Private lMouseHook As Long Private lAppHwnd As Long Private lDeskHwnd As Long Private lWkbHwnd As Long Private lDropDownHwnd As Long Sub HookValidationList() On Error Resume Next lAppHwnd = _ FindWindow("XLMAIN", Application.Caption) lDeskHwnd = FindWindowEx _ (lAppHwnd, 0, "XLDESK", vbNullString) lWkbHwnd = FindWindowEx _ (lDeskHwnd, 0, "EXCEL7", vbNullString) lCBTHook = SetWindowsHookEx _ (WH_CBT, AddressOf CBTProc, _ GetAppInstance, GetCurrentThreadId) End Sub Sub UnHookValidationList() UnhookWindowsHookEx lCBTHook UnhookWindowsHookEx lMouseHook End Sub Private Function CBTProc _ (ByVal idHook As Long, ByVal wParam As Long, _ ByVal lParam As Long) As Long Dim strBuffer As String Dim lRetVal As Long On Error Resume Next Select Case idHook Case Is = HCBT_CREATEWND strBuffer = Space(256) lRetVal = GetClassName(wParam, strBuffer, 256) If Left(strBuffer, lRetVal) = "EXCEL:" Then UnhookWindowsHookEx lCBTHook lDropDownHwnd = wParam lMouseHook = SetWindowsHookEx _ (WH_MOUSE_LL, _ AddressOf LowLevelMouseProc, GetAppInstance, 0) End If Case Is = HCBT_DESTROYWND If wParam = lDropDownHwnd Then UnhookWindowsHookEx lMouseHook End If End Select CBTProc = CallNextHookEx _ (lCBTHook, idHook, ByVal wParam, ByVal lParam) End Function Private Function LowLevelMouseProc _ (ByVal nCode As Long, ByVal wParam As Long, _ ByRef lParam As MSLLHOOKSTRUCT) As Long On Error Resume Next If (nCode = HC_ACTION) Then If wParam = WM_MOUSEWHEEL Then LowLevelMouseProc = True If lParam.mouseData > 0 Then SendKeys "{UP}" Else SendKeys "{DOWN}" End If Exit Function End If With lParam.pt If WindowFromPoint(.X, .Y) <> lDropDownHwnd _ And WindowFromPoint(.X, .Y) <> lWkbHwnd Then ShowWindow lDropDownHwnd, 0 End If End With End If LowLevelMouseProc = _ CallNextHookEx(lMouseHook, nCode, wParam, ByVal lParam) End Function Private Function GetAppInstance() As Long GetAppInstance = GetWindowLong(lAppHwnd, GWL_HINSTANCE) End Function وان شاء الله يعمل معكم بالشكل الذي تريدونه جزاكم الله خيرا

الاخوة الكرام بعد اذن اخي الحبيب / شوقي ربيع اقدم لكم ملف به كود للعلامة القدير / جعفر طرباق المغربي به كود لتنفيذ الطلب الخاص بـ Data Validation List اليكم الملف بالمرفقات به الاكواد ... وطريقة وضع الاكواد في المشاركة التالية ارجو ان يفي بطلبكم DataValidationMouseScroll.rar

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

شاهد الرابط التالي http://www.officena.net/ib/index.php?showtopic=46295

الاخ الكريم / وضاح شاهد المرفقات التالية مستند محمد 1.rar ALIDROOS_F.rar

شاهد اولا اخي الكريم الشرح الكامل للكود وطريقة تنفيذه شرح مبسط وسهل وشرح للكود سطر سطر ( فيديو ) واظن انه سيفيدك في تعديل الكود بنفسك .. واي استفسارات معك دائما وذلك في الموضوع التالي طريقة عمل او استخراج كشف حساب بالاكواد بطريقة بسيطة !! خطوة خطوة http://www.officena....showtopic=46008

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

وان كان كما فهمت من سؤالك وكما تم ارفاقه فالحل يكون من قائمة تنسيق خلايا --- محاذاة --- واختيار الخيارات الموجودة في الصورة التالية اما ان كان غير ذلك فبرجاء مزيد من التوضيح

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

رمضـــان كـــريـــم

الاخ الكريم / رسول هادي هل تقصد هذا الشكل للنص في الخلايا المدمجة

رمضـــان كـــريـــم

جزاك الله خيرا ... اخي الكريم / حسين وجزا صاحب الملف خيرا وجعله في ميزان حسناتكم

السلام عليكم الاخ الكريم / mabrouk1234 بارك الله فيك وبعد اذن اخي الحبيب الخلوق الراائع / ضاحي الغريب ... جزاه الله خيرا وبعد اذن الاخ الكريم / مصطفي .. علي التدخل في موضوعه اليك اخي الكريم ماطلبت علي الرابط التالي في المشاركة رقم 211 # http://www.officena.net/ib/index.php?showtopic=46420&page=11#entry291531 جزاكم الله خيرا

السلام عليكم الاخ الكريم / mabrouk1234 بارك الله فيك شاهد المرفق التالي تم تنفيذ ما طلبته فيه بوضع الاكواد رجاء تجربته .. واخباري بالنتيجة هل هو كما تريد ام ان هناك بعض التعديلات الاخري رمضان كريم جزاك الله خيرا سند قبض1 .rar