ara bul

[mozdem]

Çok çalıştım ama yapamadım, bir bakarsanız sevinirim. Dosyam ekte.
yapmak istediğim;

ŞART-1
'A2:A500 hücrelerinden 1 tanesine veri girersem;
'veri girilen hücrenin bir alt satırındaki B: G sütunları arasında arasın.
'Örnek: A3 hücresine "Ayşe" ismi girildiğinde, B4:G4 hücreler arasında 'arasın.

'Aranan var ise ; Bulunan hücre seçilsin. ve Mesaj versin.
'Aranan veri yok ise ; B4:G4 te Boş hücreye veriyi yazsın.

'ŞART-2
'A2:A500 hücrelerinden 1 veri silersem;
'Silinen veriyi B4:G4 arasında arasın.

'Silinen veri var ise; O hücredeki veri silinsin.
'Silinen veri Yok ise; Exit sub

 

[Korhan Ayhan]

Merhaba,

Aşağıdaki kodu deneyiniz.

Dim Aranan As Variant

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim BUL As Range
    If Intersect(Target, Range("A2:A500")) Is Nothing Then Exit Sub
    If Target.Cells.Count > 1 Then Exit Sub
    If Target <> "" Then
        Set BUL = Cells(Target.Row + 1, 2).Resize(1, 6).Find(Target, , , xlWhole)
        If Not BUL Is Nothing Then
            BUL.Select
            MsgBox "Bulunan kayıt ; " & Target, vbInformation, "Kayıt bulundu !"
        Else
            For X = 2 To 7
                If Cells(Target.Row + 1, X) = "" Then
                    Cells(Target.Row + 1, X) = Target
                    Exit For
                End If
            Next
        End If
    Else
        Set BUL = Cells(Target.Row + 1, 2).Resize(1, 6).Find(Aranan, , , xlWhole)
        If Not BUL Is Nothing Then BUL.ClearContents
    End If
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Intersect(Target, Range("A2:A500")) Is Nothing Then Exit Sub
    Range("B1").Value = Target.Value
End Sub

 

[mozdem]

Merhaba,

Aşağıdaki kodu deneyiniz.

Dim Aranan As Variant

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim BUL As Range
    If Intersect(Target, Range("A2:A500")) Is Nothing Then Exit Sub
    If Target.Cells.Count > 1 Then Exit Sub
    If Target <> "" Then
        Set BUL = Cells(Target.Row + 1, 2).Resize(1, 6).Find(Target, , , xlWhole)
        If Not BUL Is Nothing Then
            BUL.Select
            MsgBox "Bulunan kayıt ; " & Target, vbInformation, "Kayıt bulundu !"
        Else
            For X = 2 To 7
                If Cells(Target.Row + 1, X) = "" Then
                    Cells(Target.Row + 1, X) = Target
                    Exit For
                End If
            Next
        End If
    Else
        Set BUL = Cells(Target.Row + 1, 2).Resize(1, 6).Find(Aranan, , , xlWhole)
        If Not BUL Is Nothing Then BUL.ClearContents
    End If
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Intersect(Target, Range("A2:A500")) Is Nothing Then Exit Sub
    Range("B1").Value = Target.Value
End Sub

Çok çalıştım. ama yapamamıştım. Ellerinize, emeğinize sağlık.
Çok teşekkür ederim. İyi çalışmalar dilerim