kemal turan
Altın Üye
- Katılım
- 10 Haziran 2011
- Mesajlar
- 1,674
- Excel Vers. ve Dili
- Excel 2010 32 bit
- Altın Üyelik Bitiş Tarihi
- 06-10-2032
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.
Kod:
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