İki Koşullu Filtreleme

[DrsnDrsn]

Merhaba,

Ek olarak paylaştığım örnek çalışma dosyasında ki gibi belirli koşullara sahip filtreleme işlemini nasıl yapabilirim? Yardımlarınızı bekliyorum.

 

[DrsnDrsn]

+++

 

[ÖmerFaruk]

Aşağıdaki kodu sayfa1 içindeyken çalıştırabilirsiniz.
Sayfa2 ye yazdırdım.

Sub Listele()
    Dim Veri, Liste(), i As Integer, Say As Integer, k As Integer
    Veri = Range("A1").CurrentRegion.Value
    For i = 2 To UBound(Veri, 2)
        If Veri(UBound(Veri), i) <= WorksheetFunction.Small(Range(Cells(UBound(Veri), 2), Cells(UBound(Veri), UBound(Veri, 2))), 3) Then
            If Veri(3, i) / Veri(2, i) = 1 Or Veri(3, i) / Veri(2, i) = 2 Then
                Say = Say + 1
                ReDim Preserve Liste(1 To UBound(Veri), 1 To Say)
                For k = 1 To UBound(Veri)
                    Liste(k, Say) = Veri(k, i)
                Next k
            End If
        End If
    Next i
    'Ben sayfa2 A1 hücresinden itibaren listeledim, siz kendinize göre uyarlarsınız
    Worksheets("Sayfa2").Cells.Clear
    If Say > 0 Then Worksheets("Sayfa2").Range("A1").Resize(UBound(Liste), Say) = Liste
    Erase Veri: Erase Liste: Say = Empty: i = Empty: k = Empty
End Sub

 

[DrsnDrsn]

Aşağıdaki kodu sayfa1 içindeyken çalıştırabilirsiniz.
Sayfa2 ye yazdırdım.

Sub Listele()
    Dim Veri, Liste(), i As Integer, Say As Integer, k As Integer
    Veri = Range("A1").CurrentRegion.Value
    For i = 2 To UBound(Veri, 2)
        If Veri(UBound(Veri), i) <= WorksheetFunction.Small(Range(Cells(UBound(Veri), 2), Cells(UBound(Veri), UBound(Veri, 2))), 3) Then
            If Veri(3, i) / Veri(2, i) = 1 Or Veri(3, i) / Veri(2, i) = 2 Then
                Say = Say + 1
                ReDim Preserve Liste(1 To UBound(Veri), 1 To Say)
                For k = 1 To UBound(Veri)
                    Liste(k, Say) = Veri(k, i)
                Next k
            End If
        End If
    Next i
    'Ben sayfa2 A1 hücresinden itibaren listeledim, siz kendinize göre uyarlarsınız
    Worksheets("Sayfa2").Cells.Clear
    If Say > 0 Then Worksheets("Sayfa2").Range("A1").Resize(UBound(Liste), Say) = Liste
    Erase Veri: Erase Liste: Say = Empty: i = Empty: k = Empty
End Sub

Bazı aksaklıklardan dolayı cevabınızı geç gördüm. Teşekkür ederim.