Veri süzme

[sedat2161]

İyi sabahla, iyi çalışmalar. Ekteki puantaj dosyamda B7, c7 ve d7 hücrelerine alttaki personel bilgilerini yani t.c numarası ve ad soyad bilgilerini girdiğimde bilgisini girdiğim personel ilk sıraya gelmesi gerekiyor. Yardımcı olursanız çok memenun olurum.

 

[Muzaffer Ali]

Merhaba.

Aşağıdaki kodları sayfanın kod kısmına kopyalayın.
B7 ve C7 hücrelerinde bir değişiklik olduğunda istediğiniz işlemi yapacaktır.

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Alan As Integer
    Dim Bak As Long
    Dim Say As Long
    Dim Bulundu As Boolean
    If Target.Text = "" Then Exit Sub
    Application.EnableEvents = False
    If Not Intersect(Target, Range("B7")) Is Nothing Then
        Alan = 2
    ElseIf Not Intersect(Target, Range("C7")) Is Nothing Then
        Alan = 3
    Else
        Application.EnableEvents = True
        Exit Sub
    End If
    Say = Cells(Rows.Count, Alan).End(3).Row
    For Bak = 10 To Say
        If Target.Text = Cells(Bak, Alan).Text Then
            Range("B" & Bak & ":AJ" & Bak).Cut
            Range("B10").Insert Shift:=xlDown
            Bulundu = True
            Exit For
        End If
    Next
    If Not Bulundu Then MsgBox "Aradığınız değer: '" & Target.Text & "' bulunamadı.", vbInformation
    Application.EnableEvents = True
End Sub

 

[sedat2161]

Sayın dalgalikur ilginiz için teşekkür ederim. Kodu ilgili sayfanın kod bölümüne ekledim işlem yaptığımda sorun veriyor. Bide örneğin 3. sıradaki kişiyi çağırdığımda sıra numarası değişmeden diğer kişiler gizlenecek şekilde süzme olması gerekiyor.

 

[Muzaffer Ali]

Bu istediğiniz şeyi filtre kullanarak da yapabilirsiniz aslında ama istediğiniz şeyi aşağıdaki kod ile de yapabilirsiniz.

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Alan As Integer
    Dim Bak As Long
    Dim Say As Long
    Dim Bulundu As Boolean
    If Target.Text = "" Then Exit Sub
    Application.EnableEvents = False
    Rows.EntireRow.Hidden = False
    If Not Intersect(Target, Range("B7")) Is Nothing Then
        Alan = 2
    ElseIf Not Intersect(Target, Range("C7")) Is Nothing Then
        Alan = 3
    Else
        Application.EnableEvents = True
        Exit Sub
    End If
    Say = Cells(Rows.Count, Alan).End(3).Row
    For Bak = 10 To Say
        If Target.Text = Cells(Bak, Alan).Text Then
            Rows(Bak).EntireRow.Hidden = False
            Bulundu = True
        Else
            Rows(Bak).EntireRow.Hidden = True
        End If
    Next
    If Not Bulundu Then
        Rows.EntireRow.Hidden = False
        MsgBox "Aradığınız değer: '" & Target.Text & "' bulunamadı.", vbInformation
    End If
    Application.EnableEvents = True
End Sub

 

[sedat2161]

Bu istediğiniz şeyi filtre kullanarak da yapabilirsiniz aslında ama istediğiniz şeyi aşağıdaki kod ile de yapabilirsiniz.

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Alan As Integer
    Dim Bak As Long
    Dim Say As Long
    Dim Bulundu As Boolean
    If Target.Text = "" Then Exit Sub
    Application.EnableEvents = False
    Rows.EntireRow.Hidden = False
    If Not Intersect(Target, Range("B7")) Is Nothing Then
        Alan = 2
    ElseIf Not Intersect(Target, Range("C7")) Is Nothing Then
        Alan = 3
    Else
        Application.EnableEvents = True
        Exit Sub
    End If
    Say = Cells(Rows.Count, Alan).End(3).Row
    For Bak = 10 To Say
        If Target.Text = Cells(Bak, Alan).Text Then
            Rows(Bak).EntireRow.Hidden = False
            Bulundu = True
        Else
            Rows(Bak).EntireRow.Hidden = True
        End If
    Next
    If Not Bulundu Then
        Rows.EntireRow.Hidden = False
        MsgBox "Aradığınız değer: '" & Target.Text & "' bulunamadı.", vbInformation
    End If
    Application.EnableEvents = True
End Sub

sayın dalgalikur kod çok iyi oldu. yanlız girdiğim bilgiyi sildiğim de liste yine eski haline dönmesi gerekiyor. Örneğin 3. Kişiyi çağırdım işlem bitti B2 den çağırdığım kişiyi sildiğimde listenin eski halini alması gerekiyor. Teşekkür ederim.iyi çalışmalar.

 

[Muzaffer Ali]

Rows.EntireRow.Hidden = False

Satırını

If Target.Text = "" Then Exit Sub

Satırının üstüne alın.

 

[sedat2161]

Rows.EntireRow.Hidden = False

Satırını

If Target.Text = "" Then Exit Sub

Satırının üstüne alın.

teşekkürler emeğinize sağlık.