Hücre değiştikçe çalışan Makro ve Düşeyara

[kaos3]

Arkadaşlar Merhaba.

Elimde sürekli veri girilen bir liste var.
Sayfa 1 in A sütununa kod girdiğimde bu kodu 2. sayfada düşey arasın ve B sutununa yazsın.
Eğer kod sayda 2 de yoksa B sutununa ısmı ben yazdıgımda a sutunu ve b sutununda kı verıyı Sayfa 2 deki listeye eklesin.

Böyle bir makro yapabilir miyiz?
Yardımlarınız için şimdiden teşekkür ederim.

 

[Muzaffer Ali]

Dosyanız ekte.

 

[kaos3]

Sayın Dalgalikur ellerinize, aklınıza sağlık çok güzel olmuş düşündüğümden daha iyi.

 

[kaos3]

Sayın Dalgalıkur,

Yeni bir kod eklediğimde listede en alta ekliyor ancak ikinci yeni bir kod ekleyince bir önceki kaydettiğinin üzerine yazıyor.
Birde A sütunu değilde başka bir sütunu sildiğimde" If Intersect(Target, Range("A:A")) Is Nothing Or Target = "" Then Exit Sub" hatası veriyor neden olabilir acaba?

 

[Muzaffer Ali]

Dosyadaki kodları silip aşağıdakileri kopyalayın.

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim syfBak As Worksheet
    Dim Deger As Variant
    Dim say As Long
    If Intersect(Target, Range("A:A")) Is Nothing Then Exit Sub
    If Target = "" Then Exit Sub
    Set syfBak = ThisWorkbook.Worksheets("Sayfa2")
    On Error Resume Next
    Deger = WorksheetFunction.VLookup(Target, syfBak.Range("A:B"), 2, 0)
    If Err.Number <> 0 Then
        Deger = InputBox("Girdiğiniz kod bulunamadı. Eklemek için İsim giriniz.")
        If Deger = "" Then Exit Sub
        say = syfBak.Cells(Rows.Count, "A").End(3).Row + 1
        syfBak.Range("A" & say) = Target.Value
        syfBak.Range("B" & say) = Deger
    End If
    Target(1, 2) = Deger
End Sub

 

[kaos3]

Sayın dalgalikur yardımlarınız için çok teşekkür ederim.
Eğer mümkünse c ve d sütunlarınada bilgi eklemek istiyorum inputbox yerine userform denedim ama olmadı.
Bunu yapmak ınputboxla mumkun mudur?

 

[Muzaffer Ali]

O zaman şu kodu kullanın.

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim syfBak As Worksheet
    Dim Deger As Variant
    Dim Deger2 As Variant
    Dim Deger3 As Variant
    Dim say As Long
    If Intersect(Target, Range("A:A")) Is Nothing Then Exit Sub
    If Target = "" Then Exit Sub
    Set syfBak = ThisWorkbook.Worksheets("Sayfa2")
    On Error Resume Next
    Deger = WorksheetFunction.VLookup(Target, syfBak.Range("A:D"), 2, 0)
    Deger2 = WorksheetFunction.VLookup(Target, syfBak.Range("A:D"), 3, 0)
    Deger3 = WorksheetFunction.VLookup(Target, syfBak.Range("A:D"), 4, 0)
    If Err.Number <> 0 Then
        Deger = InputBox("Girdiğiniz kod bulunamadı. Eklemek için İsim giriniz.")
        Deger2 = InputBox("Girdiğiniz kod bulunamadı. Eklemek için ""C AlanAdı"" giriniz.")
        Deger3 = InputBox("Girdiğiniz kod bulunamadı. Eklemek için ""D AlanAdı"" giriniz.")
        If Deger = "" Then Exit Sub
        say = syfBak.Cells(Rows.Count, "A").End(3).Row + 1
        syfBak.Range("A" & say) = Target.Value
        syfBak.Range("B" & say) = Deger
        syfBak.Range("C" & say) = Deger2
        syfBak.Range("D" & say) = Deger3
    End If
    Target(1, 2) = Deger
    Target(1, 3) = Deger2
    Target(1, 4) = Deger3
End Sub

Kodların çalışmasını anlayabilmek için satır satır çalıştırın.Şöyle ki;
Private Sub Worksheet_Change(ByVal Target As Range) satırı seçiliyken F9 a basarak durma noktası belirleyin.

Daha sonra F8 tuşuna basarak kodları satır satır çalıştırın.

Durma noktasını iptal etmek için yine aynı satır seçil iken F9 a basın.