filtrenin kalkması

[mcetinkaya65]

Kıymetli hocalarımızın yardımı ile filtrelenmiş bir sayfanın bilgilerini sayfa 1 aktarmayı başardım.
Değerli hocam,
Sayafa 2 deki A sütünuna Filtre uygulayıp A1 hücresine çift tıkladığımızda veriler sayfa 1 aktarılıyor.Çok güzel,fakat filtrelenen sayfasının filtresi kaldırıp tümünü seçmeyince, başka sayfalardaki işlemlerde problem çıkıyor.A1 hücresine tıklayıca hem aktarıp aynı tıklamayla filtrenin kalkması veya filtrelenmiş sayfadan başka sayfaya geçilince filtrelemenin kalkması mümkün mü?
Diğer sayfalara geçince filtrelemenin iptal edilmesi daha güzel olur.
Saygılarımla....

 

[Levent Menteşoğlu]

Dosyanızdaki ilgili kodlardaki msgbox'tan önce aşağıdaki satırı ekleyin.

ActiveSheet.ShowAllData

 

[mcetinkaya65]

Değerli hocam,
Sayfa koruması yapılan bir sayafanın ,sayfa değişikliğinde filtrelemenin kalkması mümkün değilmi?
(yukarıda bulanan dosyanın, sayfa 2 nin kodları ile beraber çakışmadan çalışacak bir kod)

 

[Korhan Ayhan]

Merhaba,

Tabiki mümkün. Kodu aşağıdaki şekilde değiştirin. Kırmızı bölümler sayfa koruma şifresidir. Kendinize göre değiştiriniz.

Ayrıca korumalı sayfanızda A1 hücresinde filtre olduğu için size çift tıklama izni vermeyecektir. Bu sebeple A1 yerine G1 hücresinde çalışacak şekilde kodu düzenledim.

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    Dim Satır As Long
    
    If Intersect(Target, Range("[COLOR=blue]G1[/COLOR]")) Is Nothing Then Exit Sub
    ActiveSheet.Unprotect "[COLOR=red]123[/COLOR]"
    Cancel = True
    If Not ActiveSheet.AutoFilter.Filters.Item(1).On Then Exit Sub
    Satır = Cells(Rows.Count, 1).End(3).Row
    If Satır = 1 Then Exit Sub
    
    Say = WorksheetFunction.Subtotal(103, Range("A2:A" & Rows.Count))
    
    With Sheets("Sayfa1")
        .Range("A:N").ClearContents
         Range("A2:N" & Satır).Copy
        .Range("A1").PasteSpecial xlValues
         Application.CutCopyMode = False
    End With
 
    ActiveSheet.ShowAllData
    ActiveSheet.Protect "[COLOR=red]123[/COLOR]", DrawingObjects:=True, Contents:=True, Scenarios:=True, AllowFiltering:=True
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[mcetinkaya65]

İlginize ve bilginize teşekkürler.