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

محمود غباشى · يناير 10, 2016

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

ارجو الافادة

ياسر خليل أبو البراء · يناير 10, 2016

أخي الكريم

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

تقبل تحيااتي

محمود غباشى · يناير 11, 2016

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

**ياسر العربى** · يناير 11, 2016

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

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

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

وشكرا

محمود غباشى · يناير 11, 2016

قمت بأرفاق شيت به الكود ارجو الافادة ولكم كل الشكر والتقدير

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

**ياسر العربى** · يناير 11, 2016

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

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

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

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

محمود غباشى · يناير 11, 2016

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

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

**ياسر العربى** · يناير 11, 2016

طيب شوف الفكرة دي كدا

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

محمود غباشى · يناير 11, 2016

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

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

**جعفر الطريبق** · يناير 14, 2016

السلام عليكم

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

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

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

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

تم تعديل يناير 14, 2016 بواسطه جعفر الطريبق

ياسر خليل أبو البراء · يناير 15, 2016

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

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

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

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

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

index.jpg.d19f574d91c8ebc8bb28ed2a216ba8

**جعفر الطريبق** · يناير 15, 2016

السلام عليكم

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

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

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

حاولت أن أجد حلا للمشكلة و هذا أقصى ما يمكن فعله ... الكود يشتغل عندي فهو يقوم بفلترة القائمة تلقائيا عند تغيير قيمة الخلية 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

تم تعديل يناير 15, 2016 بواسطه جعفر الطريبق

ياسر خليل أبو البراء · يناير 15, 2016

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

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

تقبل تحياتي

**جعفر الطريبق** · يناير 15, 2016

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

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

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

**جعفر الطريبق** · يناير 15, 2016

أسف نسيت أنني أشتغل على نسخة الاكسيل باللغة الفرنسية و بالتالي ال 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

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

تم تعديل يناير 15, 2016 بواسطه جعفر الطريبق

**جعفر الطريبق** · يناير 16, 2016

جربوا الملف في الرابط أدناه

https://app.box.com/s/8lzxirs3i6d8jpci9xe809az7odf5ngh

تم تعديل يناير 16, 2016 بواسطه جعفر الطريبق

**ياسر العربى** · يناير 16, 2016

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

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

3000 1000 2000

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

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

وشكرا

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

ياسر خليل أبو البراء · يناير 16, 2016

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

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

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

**جعفر الطريبق** · يناير 17, 2016

السلام عليكم

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

للاسف اذا بحثت عن 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

تسجيل الدخول

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

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

محمود غباشى

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

محمود غباشى

ياسر العربى

محمود غباشى

ياسر العربى

محمود غباشى

ياسر العربى

محمود غباشى

جعفر الطريبق

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

جعفر الطريبق

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

جعفر الطريبق

جعفر الطريبق

جعفر الطريبق

ياسر العربى

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

جعفر الطريبق

Join the conversation

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

تصفح الموقع

تصفح جديد الموقع

Support

Important Information