• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Sayfa Korumalı Listeleme Yapma

Yaptım galiba!
Kod: 
Private Sub TextBox1_Change()
On Error Resume Next
Application.ScreenUpdating = False
ActiveSheet.Unprotect ""
METİN1 = TextBox1.Value
Set FC2 = Range("C5:C5000").Find(What:=METİN1)
Application.Goto Reference:=Range(FC2.Address), _
   Scroll:=False
Selection.AutoFilter Field:=3, Criteria1:="*" & TextBox1.Value & "*"
If METİN1 = "" Then
Selection.AutoFilter Field:=3
End If
Application.ScreenUpdating = True
ActiveSheet.Protect ""
End Sub
 
Hangi kodlarda hata verdi sayın beyinmuhendisi? Ben açtım ve şuan gayet güzel yazdığım veriye göre filtre uygulanıyor. Sayfa koruması da hala aktif.
 
Arama yaparken problem yok. Arama sonrası hücreye tıklayınca hata veriyor.
 
Worksheet_SelectionChange olayını ne için kullanıyorsunuz ? Change olayında kullansanız ne gibi bir problem çıkıyor ?
 
Satır renklendirmek için kullanıyoruz. Benzer isimlerde sıra karışabilyor. Aksi takdirde öğrenci ismini tam yazmak gerekiyor. Bu da işlemi uzatıyor.
 
Koda aşağıdaki gibi ekleme yaptığımda 2 numaralı dosyada "TextBox" içeriğine temizleyince süzülenlerin bir kısmı geri gelmiyor.


Kod: 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
[COLOR="Red"]On Error Resume Next
Application.ScreenUpdating = False
ActiveSheet.Unprotect ""[/COLOR]
Dim Satır As Range, Sütun As Range
If Intersect(Target, [A5:Q5009]) Is Nothing Then
[A5:Q5009].FormatConditions.Delete
Exit Sub
End If
Set Satır = Range(Cells(ActiveCell.Row, 1), Cells(ActiveCell.Row, 12))
Set Sütun = Range(Cells(3, ActiveCell.Column), Cells(50, ActiveCell.Column))

Cells.FormatConditions.Delete

With Satır
.FormatConditions.Delete
.FormatConditions.Add Type:=xlExpression, Formula1:=1
.FormatConditions(1).Font.Bold = True
.FormatConditions(1).Interior.ColorIndex = 14
End With

With Sütun
.FormatConditions.Delete
.FormatConditions.Add Type:=xlExpression, Formula1:=1
.FormatConditions(1).Font.Bold = True
.FormatConditions(1).Interior.ColorIndex = 56
End With

With ActiveCell
.FormatConditions.Delete
.FormatConditions.Add Type:=xlExpression, Formula1:=1
.FormatConditions(1).Font.Bold = True
.FormatConditions(1).Interior.ColorIndex = 1
End With
[COLOR="red"]Application.ScreenUpdating = True
ActiveSheet.Protect ""[/COLOR]
End Sub
 
Son düzenleme:
Beni aşıyor üzgünüm. İnşallah üstadlardan birisi yardımcı olabilir.
 
Bu sefer de süzdükleri isimlerin bir kısmını geri getirmiyor. Yardımcı olursanız sevinirim.
 
Change olayında deneyip işlemlerinizi bi yapar mısınız ? Orda herhangi bir sıkıntı vermiyor.
 
Merhaba,

Change olayının başına aşağıdaki kodu ekleyin.
Siz bu tabloya nasıl kayıt atıyorsunuz.

On Error Resume Next
 
Kodu düzeltip yazar mısınız. Ben de neden olmuyor. Dediğiniz şekilde sayfa korumada renklendirme çalışmıyor.
 
Listele isimli sayfanızın kod bölümündeki kodları aşağıdaki gibi değiştirip deneyiniz.

Kod: 
Sub LİSTELE_BRN()
Set l = Sheets("Liste"): Set sp = Sheets("Sınıf_Para")
sp.Range("6:6").ClearContents
    For brn = 5 To l.[D65536].End(3).Row
        If l.Cells(brn, "D") <> 0 And WorksheetFunction.CountIf(sp.Range("6:6"), l.Cells(brn, "D")) = 0 _
            Then sp.Cells(6, sp.Cells(6, 256).End(1).Column + 1) = l.Cells(brn, "D")
    Next
MsgBox "Listeleme Tamamlandı!", vbInformation, "beyinmuhendisi"
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim Satır As Range, Sütun As Range
ActiveSheet.Unprotect ""
If Intersect(Target, [A5:Q5009]) Is Nothing Then
[A5:Q5009].FormatConditions.Delete
Exit Sub
End If
Set Satır = Range(Cells(ActiveCell.Row, 1), Cells(ActiveCell.Row, 12))
Set Sütun = Range(Cells(3, ActiveCell.Column), Cells(50, ActiveCell.Column))

Cells.FormatConditions.Delete

With Satır
.FormatConditions.Delete
.FormatConditions.Add Type:=xlExpression, Formula1:=1
.FormatConditions(1).Font.Bold = True
.FormatConditions(1).Interior.ColorIndex = 14
End With

With Sütun
.FormatConditions.Delete
.FormatConditions.Add Type:=xlExpression, Formula1:=1
.FormatConditions(1).Font.Bold = True
.FormatConditions(1).Interior.ColorIndex = 56
End With

With ActiveCell
.FormatConditions.Delete
.FormatConditions.Add Type:=xlExpression, Formula1:=1
.FormatConditions(1).Font.Bold = True
.FormatConditions(1).Interior.ColorIndex = 1
End With
ActiveSheet.Protect ""
End Sub
    
Private Sub TextBox1_Change()
Application.ScreenUpdating = False
Application.EnableEvents = False
ActiveSheet.Unprotect ""
METİN1 = TextBox1.Value
Set FC2 = Range("C5:C5000").Find(METİN1, , , xlPart)
If Not FC2 Is Nothing Then Application.Goto Reference:=Range(FC2.Address), Scroll:=False
Range("A4").AutoFilter Field:=3, Criteria1:="*" & METİN1 & "*"
If METİN1 = "" Then
Selection.AutoFilter Field:=3
End If
Application.EnableEvents = True
Application.ScreenUpdating = True
ActiveSheet.Protect ""
End Sub

Private Sub TextBox2_Change()
Application.ScreenUpdating = False
Application.EnableEvents = False
ActiveSheet.Unprotect ""
METİN1 = TextBox2.Value
Set FC2 = Range("D5:D5000").Find(METİN1, , , xlPart)
If Not FC2 Is Nothing Then Application.Goto Reference:=Range(FC2.Address), Scroll:=False
Range("A4").AutoFilter Field:=4, Criteria1:="*" & METİN1 & "*"
If METİN1 = "" Then
Range("A4").AutoFilter Field:=4
End If
Application.EnableEvents = True
Application.ScreenUpdating = True
ActiveSheet.Protect ""
End Sub

Private Sub TextBox3_Change()
Application.ScreenUpdating = False
Application.EnableEvents = False
ActiveSheet.Unprotect ""
NO = TextBox3.Value
Set FC2 = Range("B5:B5000").Find(NO)
If Not FC2 Is Nothing Then Application.Goto Reference:=Range(FC2.Address), Scroll:=False
Range("A4").AutoFilter Field:=2, Criteria1:=NO
If NO = "" Then
Range("A4").AutoFilter Field:=2
End If
Application.EnableEvents = True
Application.ScreenUpdating = True
ActiveSheet.Protect ""
End Sub
 
Sayın Üstadım Korhan Ayhan

Emeğinize sağlık. Teşekkür ederim!

Kodları düzenlemekten başım ağrımaya başlamıştı ki imdada yetiştiniz.

İlgilenen tüm arkadaşlara teşekkürler!
 
Üstadım son kod ile

Liste sayfası A5:Q5009 hücre aralığından sağ üstteki köprülere tıklayınca aşağıdaki renkli kod içeriğinde hata verdi.


Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim Satır As Range, Sütun As Range
ActiveSheet.Unprotect ""
If Intersect(Target, [A5:Q5009]) Is Nothing Then
[A5:Q5009].FormatConditions.Delete
Exit Sub
End If
Set Satır = Range(Cells(ActiveCell.Row, 1), Cells(ActiveCell.Row, 12))
Set Sütun = Range(Cells(3, ActiveCell.Column), Cells(50, ActiveCell.Column))

Cells.FormatConditions.Delete

With Satır
.FormatConditions.Delete
.FormatConditions.Add Type:=xlExpression, Formula1:=1
.FormatConditions(1).Font.Bold = True
.FormatConditions(1).Interior.ColorIndex = 14
End With

With Sütun
.FormatConditions.Delete
.FormatConditions.Add Type:=xlExpression, Formula1:=1
.FormatConditions(1).Font.Bold = True
.FormatConditions(1).Interior.ColorIndex = 56
End With

With ActiveCell
.FormatConditions.Delete
.FormatConditions.Add Type:=xlExpression, Formula1:=1
.FormatConditions(1).Font.Bold = True
.FormatConditions(1).Interior.ColorIndex = 1
End With
ActiveSheet.Protect ""
End Sub
Genişletmek için tıkla ...
 
Başlığı yanlış konuya açtığımı (fonksiyonlar) yeni fark ettim. Zamanınızı aldıysam kusura bakmayın.
 
Aşağıdaki gibi deneyin.

Kod: 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim Satır As Range, Sütun As Range
ActiveSheet.Unprotect ""
If Intersect(Target, [A5:Q5009]) Is Nothing Then
On Error Resume Next
[A5:Q5009].FormatConditions.Delete
On Error GoTo 0
Exit Sub
End If
Set Satır = Range(Cells(ActiveCell.Row, 1), Cells(ActiveCell.Row, 12))
Set Sütun = Range(Cells(3, ActiveCell.Column), Cells(50, ActiveCell.Column))

Cells.FormatConditions.Delete

With Satır
.FormatConditions.Delete
.FormatConditions.Add Type:=xlExpression, Formula1:=1
.FormatConditions(1).Font.Bold = True
.FormatConditions(1).Interior.ColorIndex = 14
End With

With Sütun
.FormatConditions.Delete
.FormatConditions.Add Type:=xlExpression, Formula1:=1
.FormatConditions(1).Font.Bold = True
.FormatConditions(1).Interior.ColorIndex = 56
End With

With ActiveCell
.FormatConditions.Delete
.FormatConditions.Add Type:=xlExpression, Formula1:=1
.FormatConditions(1).Font.Bold = True
.FormatConditions(1).Interior.ColorIndex = 1
End With
ActiveSheet.Protect ""
End Sub
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst