Gelişmiş Filtrelemenin Veri Getirip Getirmediğini Kontrol Etme

[Sinan73]

Merhaba,

Aşağıdaki kod ile gelişmiş filtreleme yapmaktayım. Bazen kriterlere uyan hiçbir veri olmuyor. Böyle bir durum oluştuğunda uyarı versin istiyorum. Teşekkürler.

        Application.CutCopyMode = False
        Sheets("Sayfa1").Range("Tablo1[#All]").AdvancedFilter Action:=xlFilterCopy _
        , CriteriaRange:=Range("S1:S2"), CopyToRange:=Range("A1:R1"), Unique:= _
        False

 

[hamitcan]

Aşağıdaki kodu dener misiniz ?

Sub FiltrelenmisSatir()
    a = Range("a4:a" & [a65536].End(3).Row).SpecialCells(xlCellTypeVisible).Rows.Count
    b = WorksheetFunction.Count(Range("a4:a" & [a65536].End(3).Row))
    If a - b = 0 Then MsgBox "Filrelenmiş Bir Alan Bulunmamaktadır."
End Sub

 

[Sinan73]

Galiba yanlış anlattım, size amacımı anlatayım belki yanlış bir şey yapıyorumdur.

Sayfa1 ve Sayfa2 deki verileri Sayfa3 e gelişmiş filtreleme yoluyla aktarıyorum. Dosya ektedir.
Kod:

Sub VerileriGetir()
    On Error Resume Next
    Range("A1:R65536").ClearContents
    Range("A2:R65536").Font.Bold = False
    Application.CutCopyMode = False
    Sheets("Sayfa1").Range("Tablo1[#All]").AdvancedFilter Action:=xlFilterCopy _
        , CriteriaRange:=Range("S1:S2"), CopyToRange:=Range("A1:R1"), Unique:= _
        False
        If Cells(2, 2) = "" Then
        Range("A1:R65536").ClearContents
        Application.CutCopyMode = False
        Sheets("Sayfa2").Range("Tablo2[#All]").AdvancedFilter Action:=xlFilterCopy _
        , CriteriaRange:=Range("S1:S2"), CopyToRange:=Range("A1:R1"), Unique:= _
        False
        End If
End Sub

Yapmak istediğim şey şöyle;

Eğer aşağıdaki kod veri bulamazsa,

Application.CutCopyMode = False
    Sheets("Sayfa1").Range("Tablo1[#All]").AdvancedFilter Action:=xlFilterCopy _
        , CriteriaRange:=Range("S1:S2"), CopyToRange:=Range("A1:R1"), Unique:= _
        False

Aşağıdaki kodu çalıştır.

Range("A1:R65536").ClearContents
        Application.CutCopyMode = False
        Sheets("Sayfa2").Range("Tablo2[#All]").AdvancedFilter Action:=xlFilterCopy _
        , CriteriaRange:=Range("S1:S2"), CopyToRange:=Range("A1:R1"), Unique:= _
        False

 

[hamitcan]

Koddan çok bir şey anlamadım.
Bu satırda verileri siliyorsunuz.

 Range("A1:R65536").ClearContents

Ayrıca, kriter alanı boş. Neye göre filtreleme yapıyor sunuz ?

Range("S1:S2")

 

[Sinan73]

Kodlarda karışık bir şey yok, kriter alanı boş değil.

Aşağıdaki kodlar gelişmiş filtreleme kodları.

Application.CutCopyMode = False
Sheets("Sayfa2").Range("Tablo2[#All]").AdvancedFilter Action:=xlFilterCopy _
, CriteriaRange:=Range("S1:S2"), CopyToRange:=Range("A1:R1"), Unique:= _
False

 

[hamitcan]

Bu kodları kullanır mısınız ?

Sub VerileriGetir()
    Range("A1:R65536").ClearContents
    Range("A2:R65536").Font.Bold = False
    If [s2] = "" Then MsgBox "Bir kriter girin": Exit Sub
    If HangiSayfa = "" Then MsgBox "Hiçbir veri bulunamadı": Exit Sub
    Tablo = IIf(HangiSayfa = "Sayfa1", "Tablo1", "Tablo2")
    Sheets(HangiSayfa).Range(Tablo & "[#All]").AdvancedFilter Action:=xlFilterCopy _
        , CriteriaRange:=Range("S1:S2"), CopyToRange:=Range("A1:R1"), Unique:= _
        False
        
End Sub

Function HangiSayfa()
    If Not Sheets("Sayfa1").Columns("q").Find(Sheets("Sayfa3").[s2]) Is Nothing Then
        HangiSayfa = "Sayfa1"
    ElseIf Not Sheets("Sayfa2").Columns("q").Find(Sheets("Sayfa3").[s2]) Is Nothing Then
        HangiSayfa = "Sayfa2"
    Else
    HangiSayfa = ""
    End If
End Function

 

[Sinan73]

Teşekkür ederim.

 

[assenucler]

Sayın Sinan73,

Günaydın. Sayın halit3'ün kodlarının uygulanmış halini paylaşır mısınız?

Üstadıma paylaşımı için, size de ilginiz için önceden teşekkür ederim.

 

[Sinan73]

Güncel dosya ektedir.

 

[assenucler]

Sağ olun.