Süzmeye engel koyma.

[desk]

Çalışan şekilde bir örnek dosya ekleyebilirmisiniz bende çalışmıyor.

 

[hamitcan]

D ve E sütunları süzülü ise kayıt edilebilir ve çıkılabilir olsun istiyorum.

O zaman bir çelişki var yada farklı bir kriterden daha söz ediyorsunuz.

 

[desk]

Bakın ben sanırım kendimi ifade edemedim. Benim amacım şu 4 ve 5 sütunlarda süzülü iken kayıt edip çıkabilen. Fakat başka bir sütunda süzme işlemi yaptığında kayıt edip çıkamayan bir dosya oluşturmaya çalışıyorum. Örnektede belirttim örnek dosyam tam olarak çalışıyor süzme işlemi yapmaya izin vermiyor tüm sütunlarda ama ben bu özellikten sadece 4 ve 5 sütunu dışarda bırakmak istiyorum o sütunlar süzülü olduğunda kayıt edip çıkabilmeliyim. başka sütunlar da bunun üstüne süzme yaptığımda kayıt edememeliyim.

 

[desk]

Özet : 4 - 5 sütunlarda süzüp kayıt edip çıkma açık. Bu sütunlar dışındaki Tüm sütunlarda süzme yaptıktan sonra kayıt edip çıkma kapalı.

 

[hamitcan]

Bir de böyle deneyin.

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
        With Sayfa1
            If .AutoFilterMode Then
                   For i = 1 To 3
                        If .AutoFilter.Filters(i).On Then c = c + 1
                   Next
                   If c <> 0 Then
                        MsgBox "Süzme işleminizi lütfen kaldırınız. İyi çalışmalar."
                        Cancel = True
                   End If
            End If
        End With
End Sub

 

[desk]

Sürekli uyarı veriyor süzme işlemini kaldırınız diye sizin tarafınızdan denenmiş miydi acaba?

 

[Korhan Ayhan]

Selamlar,

Aşağıdaki kodları denermisiniz.

Option Explicit
Dim X As Byte, ADRES As String
 
Private Sub Workbook_BeforeClose(Cancel As Boolean)
    ADRES = Empty
    
    For X = 1 To 5
        If X < 4 And ActiveSheet.AutoFilter.Filters.Item(X).On Then
            ADRES = ADRES & ActiveSheet.AutoFilter.Range.Cells(X).Address(0, 0) & Chr(10)
        End If
    Next
    
    If ADRES <> Empty Then
        MsgBox "Aşağıdaki sütunlara süzme işlemi uygulandığı için dosyadan çıkamazsınız !" & Chr(10) & _
        "Lütfen bu sütunlardaki süzme işlemini kaldırınız !" & Chr(10) & ADRES, vbCritical, "Dikkat !"
        Cancel = True
    End If
End Sub
 
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
    ADRES = Empty
    
    For X = 1 To 5
        If X < 4 And ActiveSheet.AutoFilter.Filters.Item(X).On Then
            ADRES = ADRES & ActiveSheet.AutoFilter.Range.Cells(X).Address(0, 0) & Chr(10)
        End If
    Next
    
    If ADRES <> Empty Then
        MsgBox "Aşağıdaki sütunlara süzme işlemi uygulandığı için dosyadan çıkamazsınız !" & Chr(10) & _
        "Lütfen bu sütunlardaki süzme işlemini kaldırınız !" & Chr(10) & Chr(10) & ADRES, vbCritical, "Dikkat !"
        Cancel = True
    End If
End Sub

 

[desk]

Korhan bey Çok çok tşk ederim. Mükemmel ötesi olmuş. Ellerinize sağlık. hamitcan beyede emekleri için çok teşekkürler.

 

[mustafaine1]

korhan Bey ve Hamit Bey gercekten guzel olmus sonuclar...