Filtreleme yardım

[Scrapie]

Ekte gönderdiğim dosya içerisinde Sayfa 2 de olayımı anlatmaya çalıştım. bir yardım ederseniz sevinirim.Teşekkürler şimdiden.

 

[Emir Hüseyin Çoban]

. . .

Sayfa2' de AY (B4) bilgisini
Sayfa1' de Görev Tarihinin ayıylamı eşleştirecek..

. . .

 

[Scrapie]

Evet Üstad

 

[antonio]

Merhaba,
Aşağıdaki kodları kullanabilirsiniz.

Dim sh As Worksheet, s1 As Worksheet, s3 As Worksheet

Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, [B3]) Is Nothing Then
Dim ay As Integer, tarih As Date, kod As String, ad As String, ss As Long, b()
If Target.Value = "" Then Exit Sub
ReDim b(1 To 9, 1 To 1)
n = 0
Set sh = Sayfa2
Set s1 = Sayfa1
Set s3 = Sayfa3
ss = s1.Range("B56789").End(3).Row
ad = Target.Value
kod = sh.Range("B2").Value
Select Case sh.Range("B4").Value
    Case Is = "Ocak"
        ay = 1
    Case Is = "Şubat"
        ay = 2
    Case Is = "Mart"
        ay = 3
    Case Is = "Nisan"
        ay = 4
    Case Is = "Mayıs"
        ay = 5
    Case Is = "Haziran"
        ay = 6
    Case Is = "Temmuz"
        ay = 7
    Case Is = "Ağustos"
        ay = 8
    Case Is = "Eylül"
        ay = 9
    Case Is = "Ekim"
        ay = 10
    Case Is = "Kasım"
        ay = 11
    Case Is = "Aralık"
        ay = 12
    Case Else
        Exit Sub
End Select
For i = 2 To ss
    y = CLng(Year(s1.Range("E" & i).Value))
    a = CInt(Month(s1.Range("E" & i).Value))
    g = CInt(Day(s1.Range("E" & i).Value))
    If ay = a Then
        If s1.Range("B" & i) Like ad Then
            If s1.Range("C" & i) Like kod Then
                n = n + 1
                ReDim Preserve b(1 To 9, 1 To n)
                For d = 1 To 9
                    b(d, n) = s1.Cells(i, d)
                Next d
            End If
        End If
    End If
Next i
s3.Range("A2:I1000").ClearContents
If n = 0 Then Exit Sub
s3.Range("A2").Resize(n, 9).Value = Application.Transpose(b)
End If
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Not Intersect(Target, [B3]) Is Nothing Then
Dim z As Object, aranan As String, ss As Long, isim As String

    Set sh = Sayfa2
    Set s1 = Sayfa1
    ReDim b(0)
    ss = s1.Range("B56789").End(3).Row
    aranan = sh.Range("B2").Value
    Set z = CreateObject("scripting.dictionary")
        z.comparemode = vbTextCompare
        n = 0
    For i = 2 To ss
        If s1.Range("C" & i).Value = aranan Then
            If s1.Range("B" & i).Value <> "" Then
                If Not z.exists(s1.Range("B" & i).Value) Then
                isim = s1.Range("B" & i).Value
                    n = n + 1
                    ReDim Preserve b(n)
                    z.Add isim, n
                    b(n) = isim
                End If
            End If
        End If
    Next i
    sh.Range("K2:K1000").ClearContents
    sh.Range("K2").Resize(n, 1).Value = Application.Transpose(b)
    ThisWorkbook.Names.Add Name:="isimler", RefersToR1C1:="=" & sh.Name & "!R3C11:R" & n + 1 & "C11"
    Target.Validation.Delete
    Target.Validation.Add xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:="=isimler"
End If
End Sub

Dosyanız ektedir.

 

[Scrapie]

Teşekkürler

 

[Emir Hüseyin Çoban]

.

Alternatif...
Kırmızı alandan isim seçildiğinde kodlar çalışır..


.