اذهب الي المحتوي
أوفيسنا

توقف خاصية undo و redo عن العمل بمجرد تفعيل الكود

محمود غباشى

بواسطه محمود غباشى
في منتدى الاكسيل Excel

 مشاركة

الردود الموصى بها

محمود غباشى

محمود غباشى

قام بنشر
قام بنشر

If Range("A3").Value = "" Then
ActiveSheet.Range("A5:Q2300").AutoFilter Field:=1
Else
("With Sheets("Sheet1
Range("A5:Q2300").AutoFilter Field:=1, Criteria1:=.Range("A3").Value 
End With
End If

 

استخدمت الكود السابق لعمل فلتر متغير بقيمة الخلية A3 ولكنى لاحظت توقف خاصية undo و redo بمجرد تفعيل الكود على procedure

 (Private Sub Worksheet_Change(ByVal Target As Range

ارجو الافادة

رابط هذا التعليق
شارك
ياسر خليل أبو البراء

ياسر خليل أبو البراء

قام بنشر
قام بنشر

أخي الكريم

عند التعامل مع الأكواد يراعى دائماً الحيطة والحذر لأن الكود لا يسمح بالتراجع .. ولذا ينصح دائماً بتجربة الكود على نسخة من الملف بعيداً عن الملف الأصلي

تقبل تحيااتي

  • Like 1
رابط هذا التعليق
شارك
ياسر العربى

ياسر العربى

قام بنشر
قام بنشر

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

لتساعد الاخوة في حل اسرع لمشكلتك وباذن الله تكون سهلة

ونرجو مراجعة توجيهات المنتدى وتغيير اسمك للغة العربية

وشكرا

رابط هذا التعليق
شارك
ياسر العربى

ياسر العربى

قام بنشر
قام بنشر

مش كدا افضل البحث بزر عند الضغط على الزر يعمل  الفلتر

وتقدر تتراجع عن تعديل البيانات قبل الضغط على الزر فقط

هل هذا ما تحتاجه ام غير ذلك

فلتر بقيمة خلية.rar

رابط هذا التعليق
شارك
محمود غباشى

محمود غباشى

قام بنشر
  • الكاتب
قام بنشر

جزاك الله خير ,, ولكن لاختصار خطوات العمل قمت بعمل البحث  داخل خلية

 هل ممكن تعديل للكود بحيث انه يعمل على الخلية ولكن يدعم undo , redo  ولا مفيش امكانية لذلك

رابط هذا التعليق
شارك
محمود غباشى

محمود غباشى

قام بنشر
  • الكاتب
قام بنشر

قمت بعمل تعديل بسيط استخدمت call لاستدعاء الكود عندما تكون الخلية بها قيمة ويظل undo يعمل طالما الخلية فارغه ولكنى اريد ان تعرض كامل البيانات اذا كانت الخلية فارغه مع توقف عمل الكود بحيث يظل undo يعمل 

 

تعديل Call فلتر بقيمة خلية.rar

رابط هذا التعليق
شارك
جعفر الطريبق

جعفر الطريبق

قام بنشر
قام بنشر (معدل)

السلام عليكم

أستاذ محمود غباشي


ان خاصية ال Undo-Redo دائما تتوقف عن العمل في اكسيل كلما تم تنفيذ أي كود يقوم بتغيير محيط الاكسيل مثل تغيير محتوى الخلايا أو الألوان أو الفلترة و غيرها ... و هذا مشكل معروف في الاكسيل يشتكي منه الكثيرون

الحل الوحيد الذي يخطر ببالي هو اجراء التغييرات ( أي الفلترة في هذه الحالة) بواسطة ال SendKeys 

لو عندي وقت سأكتب الكود و أنشره هنا 

 

تم تعديل بواسطه جعفر الطريبق
  • Like 1
رابط هذا التعليق
شارك
ياسر خليل أبو البراء

ياسر خليل أبو البراء

قام بنشر
قام بنشر

أخي الحبيب جعفر الطريبق

لطالما أحببت أن أرى مشاركاتك بشكل دائم ..لأنك تأتي بكل ما هو جديد ومميز ولم يخطر ببال أحد

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

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

تقبل وافر تقديري واحترامي

index.jpg.d19f574d91c8ebc8bb28ed2a216ba8

رابط هذا التعليق
شارك
جعفر الطريبق

جعفر الطريبق

قام بنشر
قام بنشر (معدل)

السلام عليكم 

أخي الحبيب ياسر

 شكرا على مرورك الكريم ... تمنيت لو كان لدي الوقت لكي أشارك بانتظام أكثر

أستاذ محمود غباشي

حاولت أن أجد حلا للمشكلة و هذا أقصى ما يمكن فعله ... الكود يشتغل عندي فهو يقوم بفلترة القائمة تلقائيا عند تغيير قيمة الخلية A3 مع الحفاظ على خاصية ال Undo-Redo كما هو مطلوب

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

تفضل الملف للتحميل:

https://app.box.com/s/om3uu0y2pjilzeybd37cvedxst8j413c

أما الكود الذي استعملته فهو كالتالي:

1- الكود في محرر ورقة العمل  Sheet1: 

Option Explicit
'change below Constsnates as required
'************************************
Private Const InputCellAddress As String = "A3"
Private Const FilterRangeAddress As String = "A5:A1000"

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim lRes As Long
    On Error Resume Next
    If Target.Address(False, False) = InputCellAddress Then
        If Me.AutoFilterMode = True Then
            If Target.Value <> "" Then
                lRes = Application.WorksheetFunction.Match(Target, Application.Transpose(Range(FilterRangeAddress)), 0)
                If Err.Number = 0 Then
                    Call FilterRecords(Range(FilterRangeAddress), Target)
                End If
            Else
                    If Range(FilterRangeAddress).SpecialCells(xlCellTypeVisible).Rows.Count <> _
                        Range(FilterRangeAddress).Rows.Count And Err.Number = 0 Then
                        Call ShowAllRecords(Range(FilterRangeAddress))
                    End If
            End If
        End If
    End If
End Sub

 

2- الكود في موديول عادي  

Option Explicit

#If VBA7 Then
    Private Declare PtrSafe Sub keybd_event Lib "user32.dll" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
    Private Declare PtrSafe Function SetTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As LongPtr
    Private Declare PtrSafe Function KillTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As Long) As Long
    Private Declare PtrSafe Function GetKeyState Lib "user32.dll" (ByVal nVirtKey As Long) As Integer
    Private Declare PtrSafe Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, lParam As Any) As LongPtr
    Private Declare PtrSafe Function GetDesktopWindow Lib "user32" () As LongPtr
    Private Declare PtrSafe Function InvalidateRect Lib "user32" (ByVal hwnd As LongPtr, ByVal lpRect As Long, ByVal bErase As Long) As Long
#Else
    Private Declare Sub keybd_event Lib "user32.dll" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
    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
    Private Declare Function GetKeyState Lib "user32.dll" (ByVal nVirtKey As Long) As Integer
    Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
    Private Declare Function GetDesktopWindow Lib "user32" () As Long
    Private Declare Function InvalidateRect Lib "user32" (ByVal hwnd As Long, ByVal lpRect As Long, ByVal bErase As Long) As Long
#End If
    
Private Const WM_SETREDRAW = &HB
Private Const VK_CAPSLOCK = &H14
Private Const KEYEVENTF_EXTENDEDKEY = &H1
Private Const KEYEVENTF_KEYUP = &H2
Private oInpuCell As Range

Public Sub FilterRecords(ByVal FilterRange As Range, ByVal InputCell As Range)
    On Error GoTo ErrHandler
    Set oInpuCell = InputCell
    If GetKeyState(VK_CAPSLOCK) = 1 Then SendKeys "{CAPSLOCK}", True
    Application.Goto FilterRange.Cells(1)
    Call SendMessage(GetDesktopWindow, WM_SETREDRAW, False, 0&)
    SendKeys "%{DOWN}"
    SendKeys "+{R}"
    SendKeys oInpuCell
    SetTimer Application.hwnd, 0, 1, AddressOf FilterNow
    Exit Sub
ErrHandler:
    Call RefreshScreen
End Sub

Public Sub ShowAllRecords(ByVal FilterRange As Range)
    On Error GoTo ErrHandler
    If GetKeyState(VK_CAPSLOCK) = 1 Then SendKeys "{CAPSLOCK}", True
    Application.Goto FilterRange.Cells(1)
    Call SendMessage(GetDesktopWindow, WM_SETREDRAW, False, 0&)
    SendKeys "%{DOWN}"
    SendKeys "+{C}"
    Application.OnTime Now, "RefreshScreen"
    Exit Sub
ErrHandler:
    Call SendMessage(GetDesktopWindow, WM_SETREDRAW, True, 0&)
    InvalidateRect 0, 0, 0
End Sub

Private Sub FilterNow()
    On Error GoTo ErrHandler
    KillTimer Application.hwnd, 0
    keybd_event vbKeyReturn, 0, 0, 0
    keybd_event vbKeyReturn, 0, KEYEVENTF_KEYUP, 0
    Application.OnTime Now, "RefreshScreen"
    Exit Sub
ErrHandler:
    Call RefreshScreen
End Sub

Private Sub RefreshScreen()
    Call SendMessage(GetDesktopWindow, WM_SETREDRAW, True, 0&)
    InvalidateRect 0, 0, 0
    SendKeys "{NUMLOCK}", True
    SendKeys "{NUMLOCK}", True
    oInpuCell.Select
End Sub

 

تم تعديل بواسطه جعفر الطريبق
رابط هذا التعليق
شارك
ياسر خليل أبو البراء

ياسر خليل أبو البراء

قام بنشر
قام بنشر

أخي الغالي جعفر

جربت الملف ولم تعمل الفلترة عند كتابة السعر في الخلية A3 .. أنا أعمل على ويندوز 10 64 بت والأوفيس 2013 64 بت

تقبل تحياتي

رابط هذا التعليق
شارك
جعفر الطريبق

جعفر الطريبق

قام بنشر
قام بنشر

أستاذي الكريم ياسر

أنا أعمل على  ويندوز 10 64 بت والأوفيس 2010 64 بت و الكود يعمل جيدا عندي

استعمال ال  SendKeys  ليس أمنا و غالبا ما يسبب المشاكل ... على أي حال لننتظر الأستاذ محمود و لنرى هل سيعمل الكود عنده

 

رابط هذا التعليق
شارك
جعفر الطريبق

جعفر الطريبق

قام بنشر
قام بنشر (معدل)

أسف نسيت أنني أشتغل على نسخة الاكسيل باللغة الفرنسية و بالتالي ال Filter Box ShortCuts مختلفة عن الانجليزية 

المرجو القيام باستبدال كود الماكرو  FilterRecords بالكود التالي  (لاحظ التغيير باللون الأحمر)

Public Sub FilterRecords(ByVal FilterRange As Range, ByVal InputCell As Range)
    On Error GoTo ErrHandler
    Set oInpuCell = InputCell
    If GetKeyState(VK_CAPSLOCK) = 1 Then SendKeys "{CAPSLOCK}", True
    Application.Goto FilterRange.Cells(1)
    Call SendMessage(GetDesktopWindow, WM_SETREDRAW, False, 0&)
    SendKeys "%{DOWN}"
    SendKeys "+{E}"
    SendKeys oInpuCell
    SetTimer Application.hwnd, 0, 1, AddressOf FilterNow
    Exit Sub
ErrHandler:
    Call RefreshScreen
End Sub
 

 

الكود المعدل  

Public Sub FilterRecords(ByVal FilterRange As Range, ByVal InputCell As Range)
    On Error GoTo ErrHandler
    Set oInpuCell = InputCell
    If GetKeyState(VK_CAPSLOCK) = 1 Then SendKeys "{CAPSLOCK}", True
    Application.Goto FilterRange.Cells(1)
    Call SendMessage(GetDesktopWindow, WM_SETREDRAW, False, 0&)
    SendKeys "%{DOWN}"
    SendKeys "+{E}"
    SendKeys oInpuCell
    SetTimer Application.hwnd, 0, 1, AddressOf FilterNow
    Exit Sub
ErrHandler:
    Call RefreshScreen
End Sub

باقي الكود يبقى كما هو

تم تعديل بواسطه جعفر الطريبق
  • Like 3
رابط هذا التعليق
شارك
ياسر العربى

ياسر العربى

قام بنشر
قام بنشر

شكرا اخي جعفر على هذا الملف الرائع

وتظل المشكلة التى ذكرتها وهي اذا كان البحث عن 30 او 10 او 20 تأتي 300 او 100 او 200

3000 1000 2000

ياريت نلاقي لها حل ليكتمل العمل باذن الله

 

مرفق نفس الملف للتسهيل على الاعضاء في تحميله

وشكرا

فلتر بقيمة خلية 2222.rar

  • Like 1
رابط هذا التعليق
شارك
ياسر خليل أبو البراء

ياسر خليل أبو البراء

قام بنشر
قام بنشر

أخي الحبيب جعفر

جرب أن تضع بعض القيم في الخلية المخصصة للفلترة ..النتائج مضبوطة ..

جرب تعمل Ctrl + Z للتراجع أكثر من مرة وشوف النتائج ..

 

رابط هذا التعليق
شارك
جعفر الطريبق

جعفر الطريبق

قام بنشر
قام بنشر

السلام عليكم

الأستاذ نحنود غباشي

للاسف اذا بحثت عن 30 تأتي 300 و 3000 الخ ... لا يخطر ببالي حل لهذه المشكلة لأن الكود يعتمد على SendKeys و ليس على ال Excel Object Model 

الأستاذ ياسر

الكود يحافظ على خاصية ال  Undo-Redo  لكنه ليس دقيقا و لا مأمونا مائة في المائة 

ربما اضافة Application.EnableEvents = False يساعد شوية كالتالي 

Option Explicit

#If VBA7 Then
    Private Declare PtrSafe Sub keybd_event Lib "user32.dll" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
    Private Declare PtrSafe Function SetTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As LongPtr
    Private Declare PtrSafe Function KillTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As Long) As Long
    Private Declare PtrSafe Function GetKeyState Lib "user32.dll" (ByVal nVirtKey As Long) As Integer
    Private Declare PtrSafe Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, lParam As Any) As LongPtr
    Private Declare PtrSafe Function GetDesktopWindow Lib "user32" () As LongPtr
    Private Declare PtrSafe Function InvalidateRect Lib "user32" (ByVal hwnd As LongPtr, ByVal lpRect As Long, ByVal bErase As Long) As Long
#Else
    Private Declare Sub keybd_event Lib "user32.dll" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
    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
    Private Declare Function GetKeyState Lib "user32.dll" (ByVal nVirtKey As Long) As Integer
    Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
    Private Declare Function GetDesktopWindow Lib "user32" () As Long
    Private Declare Function InvalidateRect Lib "user32" (ByVal hwnd As Long, ByVal lpRect As Long, ByVal bErase As Long) As Long
#End If
    
Private Const WM_SETREDRAW = &HB
Private Const VK_CAPSLOCK = &H14
Private Const KEYEVENTF_EXTENDEDKEY = &H1
Private Const KEYEVENTF_KEYUP = &H2
Private oInpuCell As Range

Public Sub FilterRecords(ByVal FilterRange As Range, ByVal InputCell As Range)
    On Error GoTo ErrHandler
    Application.EnableEvents = False
    Set oInpuCell = InputCell
    If GetKeyState(VK_CAPSLOCK) = 1 Then SendKeys "{CAPSLOCK}", True
    Application.GoTo FilterRange.Cells(1)
    Call SendMessage(GetDesktopWindow, WM_SETREDRAW, False, 0&)
    SendKeys "%{DOWN}"
    SendKeys "+{R}"
    SendKeys oInpuCell
    SetTimer Application.hwnd, 0, 1, AddressOf FilterNow
    Exit Sub
ErrHandler:
    Call RefreshScreen
End Sub

Public Sub ShowAllRecords(ByVal FilterRange As Range)
    On Error GoTo ErrHandler
    Application.EnableEvents = False
    If GetKeyState(VK_CAPSLOCK) = 1 Then SendKeys "{CAPSLOCK}", True
    Application.GoTo FilterRange.Cells(1)
    Call SendMessage(GetDesktopWindow, WM_SETREDRAW, False, 0&)
    SendKeys "%{DOWN}"
    SendKeys "+{C}"
    Application.OnTime Now, "RefreshScreen"
    Exit Sub
ErrHandler:
    Call SendMessage(GetDesktopWindow, WM_SETREDRAW, True, 0&)
    InvalidateRect 0, 0, 0
    Application.EnableEvents = True
End Sub

Private Sub FilterNow()
    On Error GoTo ErrHandler
    KillTimer Application.hwnd, 0
    keybd_event vbKeyReturn, 0, 0, 0
    keybd_event vbKeyReturn, 0, KEYEVENTF_KEYUP, 0
    Application.OnTime Now, "RefreshScreen"
    Exit Sub
ErrHandler:
    Call RefreshScreen
End Sub

Private Sub RefreshScreen()
    Call SendMessage(GetDesktopWindow, WM_SETREDRAW, True, 0&)
    InvalidateRect 0, 0, 0
    SendKeys "{NUMLOCK}", True
    SendKeys "{NUMLOCK}", True
    oInpuCell.Select
    Application.EnableEvents = True
End Sub

 

رابط هذا التعليق
شارك

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.

زائر
اضف رد علي هذا الموضوع....

×   Pasted as rich text.   Paste as plain text instead

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

×
 مشاركة
الذهاب الي قائمه المواضيع

  • تصفح هذا الموضوع مؤخراً   0 اعضاء متواجدين الان

    • لايوجد اعضاء مسجلون يتصفحون هذه الصفحه
×
×
  • اضف...

Important Information

  I accept