filtreye göre liste

[muhsar]

iyi akşamlar,ekteki çalışma kitabımın 2.sayfasında filtre var.filtre isimli sayfa a2 hücresine yazdığım tarihe göre 1.sayfadaki 3.sütuna göre süzme yapıyor.ben kod da ki son sütuna göre süzme yapmak için sütun sayısını gösteren( 3 )gösteren alanı 10 yaptığımda ve ekip 1 yazdığımda hata alıyorum çünkü kodda tarih olacağı şeklinde düzenlendi

benim ricam, 10 sütuna göre de filtre yapabilmek.3.sayfadaki aynı kodu uyarlamamız mümkünmü.

 

[muhsar]

güncel

 

[Ziynettin]

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address(0, 0) = "A2" Then
    Dim tarih As String
    Set s1 = Sheets("sayfa1")
    son = s1.Cells(Rows.Count, 3).End(3).Row
    a = s1.Range("A1:J" & son).Value
        If Target = "" Then
            MsgBox "Hatalı giriş.", vbCritical
            Exit Sub
        End If
    tarih = Target
    ReDim b(1 To UBound(a), 1 To UBound(a, 2))
        For i = 1 To UBound(a)
            If a(i, 10) = tarih Then
                s = s + 1
                For j = 1 To UBound(a, 2)
                    b(s, j) = a(i, j)
                Next j
            End If
        Next i
    son1 = [A:J].Find("?", , , , xlByRows, xlPrevious).Row
    If son1 > 3 Then
        Range("A4:J" & son1) = ""
        Range("A4:J" & son1).Borders.LineStyle = xlNone
        Range("A4:J" & son1).Interior.ColorIndex = xlNone
    End If
    If s > 0 Then
        [B4].Resize(s, 2).NumberFormat = "dd.mm.yyyy"
        [A4].Resize(s, UBound(a, 2)) = b
        [A4].Resize(s, UBound(a, 2)).Borders.LineStyle = 1
        MsgBox "Verileriniz yazdırıldı.", vbInformation
    Else
        MsgBox "Kayıt bulunamdı.", vbExclamation
    End If
End If
End Sub

 

[muhsar]

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address(0, 0) = "A2" Then
    Dim tarih As String
    Set s1 = Sheets("sayfa1")
    son = s1.Cells(Rows.Count, 3).End(3).Row
    a = s1.Range("A1:J" & son).Value
        If Target = "" Then
            MsgBox "Hatalı giriş.", vbCritical
            Exit Sub
        End If
    tarih = Target
    ReDim b(1 To UBound(a), 1 To UBound(a, 2))
        For i = 1 To UBound(a)
            If a(i, 10) = tarih Then
                s = s + 1
                For j = 1 To UBound(a, 2)
                    b(s, j) = a(i, j)
                Next j
            End If
        Next i
    son1 = [A:J].Find("?", , , , xlByRows, xlPrevious).Row
    If son1 > 3 Then
        Range("A4:J" & son1) = ""
        Range("A4:J" & son1).Borders.LineStyle = xlNone
        Range("A4:J" & son1).Interior.ColorIndex = xlNone
    End If
    If s > 0 Then
        [B4].Resize(s, 2).NumberFormat = "dd.mm.yyyy"
        [A4].Resize(s, UBound(a, 2)) = b
        [A4].Resize(s, UBound(a, 2)).Borders.LineStyle = 1
        MsgBox "Verileriniz yazdırıldı.", vbInformation
    Else
        MsgBox "Kayıt bulunamdı.", vbExclamation
    End If
End If
End Sub

çok teşekkür ederim elinize sağlık

 

[3641]

Yukarıdaki muhsar adlı üyenin çalışması 0,001 den büyükse olarak uyarlanabilir mi?