طلب كود فيجوال لنسخ ولصق بالقيم

[abu_hassan63]

اسادة/ الفاضل

بعد التحية 

برجاء التكرم بالمساعدة بتطوير الكود التالي للتصفية والنسخ واللصق بنفس الشيت وبنفس  الخلايا بالقيم

بشرط محدد وتكرر العملية في كل تصفية والتي تختلف كل مرة عن الأخرى حسب الشرط للتصفية

مع جزيل الشكر ميما يلي الكود الموجود لدي

Sub copy_paste_value()
'
' Macro2 Macro
'

'
    ActiveSheet.Range("$A$2:$U$9").AutoFilter Field:=1, Criteria1:=">0"
    Range("B4:Q4").Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
        
End Sub
 

Module1.rar

[احمدزمان]

السلام عليكم و رحمة الله وبركاته

اخي الفاضل

كما فهمت ان المطلوب التخلص من الدوال و استبدالها بقيم للنطاق الظاهر امامك على الشاشة بعد عمل التصفية

ولا يتم استبدا الدوال للصفوف المخفية مع التصفية

جرب هذا الكود

Sub az1()
'
' 16/02/2018   AZ
'
    Dim RN As Range
    Range("$A$2:$U$9").AutoFilter Field:=1, Criteria1:=">0"
    Range("A2:U9").SpecialCells(xlCellTypeVisible).Select
    For Each RN In Selection
    If RN.HasFormula = True Then
    RN = RN.Value
    End If
    Next
    
    
End Sub

 

[Progamerz]

السلام عليكم

حسب ما فهمت ، ان كنت تريد ان يكون التصفية ديناميكية لا ثابته، يرجى إلقاء نظره علي هذا المرفق

 

Sub filter()
Dim filterRule As Variant

Dim FindString As String
Dim Rng As Range

Dim testRange As Range
Dim targetWorksheet As Worksheet

ActiveSheet.Range("$A$1:$E$10").AutoFilter Field:=1, Criteria1:=ActiveSheet.Range("M1").Value

FindString = ActiveSheet.Range("M1").Value
If Trim(FindString) <> "" Then
    With ActiveSheet.Range("A:A")
        Set Rng = .Find(What:=FindString, _
                    After:=.Cells(.Cells.Count), _
                    LookIn:=xlValues, _
                    LookAt:=xlWhole, _
                    SearchOrder:=xlByRows, _
                    SearchDirection:=xlNext, _
                    MatchCase:=False)
        If Not Rng Is Nothing Then
            With ActiveSheet
                .Cells(Rng.Row, 2).Select
                Set testRange = .Range(.Cells(Rng.Row, 2), .Cells(Rng.Row, ActiveSheet.Range("N1").Value))
            End With
            testRange.Select
            Selection.Copy
            Selection.PasteSpecial xlPasteValues
            Application.CutCopyMode = False
        Else
            MsgBox "Nothing found with '" & FindString & "'"
        End If
    End With
End If
End Sub

 

Dynamic filtering.xlsm

[abu_hassan63]

السلام عليكم ورحمة الله وبركاته

أتقدم بالشكر من الأخ احمد زمان والأخ بروجامرز

وكود الأخ بروجامرز مناسب لطلبي أكثر وأكرر الشكر الجزيل له 

وبارك الله بكم جميعا

تم تعديل فبراير 19, 2018 بواسطه abu_hassan63