Çalışma sayfasında tarih filtreleme hk.

[kemal turan]

merhaba aşağıdaki kodu yapay zeka ile elde ettim sayfada 3 ncü satırdaki hücrelere veri yazarak filtreleme yapıyorum. ama aranan ve arınlan sutun tarih olduğunda filtreleme yapmıyor. yardımlarınızı rica ediyorum.

Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, Me.Range("B3:Q3")) Is Nothing Then

        Application.ScreenUpdating = False
        On Error GoTo ErrorHandler ' Hata işleme ekleyelim

        Dim filterCriteria(1 To 16) As String ' 16 sütun kriteri için
        Dim ws As Worksheet
        Dim lastRow As Long
        Dim i As Integer
        Dim rng As Range
        Dim criteriaApplied As Boolean

        ' Sayfayı belirleyin
        Set ws = ThisWorkbook.Worksheets("TUM_KAYITLAR") ' Sayfa adını gerektiği gibi değiştirin

        ' B3:Q3 aralığındaki değerleri alın
        For i = 1 To 16
            filterCriteria(i) = Me.Cells(3, i + 1).value ' B3:Q3 hücrelerini oku
        Next i

        ' Son satırı belirle
        lastRow = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row

        ' Filtreleme yapılacak aralığı tanımla
        Set rng = ws.Range("B4:Q" & lastRow) ' Veri aralığı: B4:Q son satır

        ws.AutoFilterMode = False ' Önceden varsa filtreyi temizle

        criteriaApplied = False ' Filtre uygulanıp uygulanmadığını kontrol et

        ' Her sütun için filtreleme uygula
        For i = 1 To 16
            If filterCriteria(i) <> "" Then
                criteriaApplied = True
                
                ' Eğer veri tarihse
                If IsDate(filterCriteria(i)) Then
                    Dim filterSerial As Long
                    filterSerial = CLng(CDate(filterCriteria(i))) ' Tarihi seri numarasına çevir
                    
                    ' Seri numarasına göre tam eşleşme
                    rng.AutoFilter Field:=i, Criteria1:="=" & filterSerial
                Else
                    ' Metin veya diğer veri türleri için joker karakter
                    rng.AutoFilter Field:=i, Criteria1:="*" & filterCriteria(i) & "*"
                End If
            End If
        Next i

        ' Hiçbir filtre uygulanmadıysa, filtreyi kaldır
        If Not criteriaApplied Then
            ws.AutoFilterMode = False
        End If

        Application.ScreenUpdating = True ' Ekran güncellemeyi tekrar aç
    End If

    Exit Sub ' Hata yoksa normal çıkış

ErrorHandler:
    MsgBox "Bir hata oluştu: " & Err.Description ' Hata mesajını göster
    Application.ScreenUpdating = True ' Hata sonrası ekran güncellemesini aç
End Sub

 

[pitchoute]

Merhaba, şu şekilde dener misiniz;

Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, Me.Range("B3:Q3")) Is Nothing Then

        Application.ScreenUpdating = False
        On Error GoTo ErrorHandler ' Hata işleme ekleyelim

        Dim filterCriteria(1 To 16) As String ' 16 sütun kriteri için
        Dim ws As Worksheet
        Dim lastRow As Long
        Dim i As Integer
        Dim rng As Range
        Dim criteriaApplied As Boolean

        ' Sayfayı belirleyin
        Set ws = ThisWorkbook.Worksheets("TUM_KAYITLAR") ' Sayfa adını gerektiği gibi değiştirin

        ' B3:Q3 aralığındaki değerleri alın
        For i = 1 To 16
            filterCriteria(i) = Me.Cells(3, i + 1).Value ' B3:Q3 hücrelerini oku
        Next i

        ' Son satırı belirle
        lastRow = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row

        ' Filtreleme yapılacak aralığı tanımla
        Set rng = ws.Range("B4:Q" & lastRow) ' Veri aralığı: B4:Q son satır

        ws.AutoFilterMode = False ' Önceden varsa filtreyi temizle

        criteriaApplied = False ' Filtre uygulanıp uygulanmadığını kontrol et

        ' Her sütun için filtreleme uygula
        For i = 1 To 16
            If filterCriteria(i) <> "" Then
                criteriaApplied = True
                
                If IsDate(filterCriteria(i)) Then
                    Dim filterDate As Date
                    filterDate = CDate(filterCriteria(i))
                    rng.AutoFilter Field:=i, Criteria1:="=" & filterDate
                Else
                    rng.AutoFilter Field:=i, Criteria1:="*" & filterCriteria(i) & "*"
                End If
            End If
        Next i

        If Not criteriaApplied Then
            ws.AutoFilterMode = False
        End If

        Application.ScreenUpdating = True
    End If

    Exit Sub 

ErrorHandler:
    MsgBox "Bir hata oluştu: " & Err.Description 
    Application.ScreenUpdating = True 
End Sub

 

[kemal turan]

SÜPER...
çok teşekkür ediyorum
Selametle Kalınız

 

[pitchoute]

Rica ediyorum, sağlıkla iyi çalışmalar.