Farklı İse Alt Satıra Kaydetmek

[ormann]

Merhabalar;
Ekli örnek dosyada dikili girişi sayfasında T9 hücresindeki veriyi butona bastığımızda A3 hücresinden başlayarak sırasıyla alt alta kayıt yapmak istiyorum. Eğer aynı kayıt varsa üzerine kayıt olacak. Kayıt farklı ise bir alt satıra kayıt yapacak.
Örneğin:T9 hücresinde ALİ varsa AU3 hücresine ALİ yazacak. T9 hücresinde VELİ varsa AU4 hücresine VELİ yazacak.Yardımcı olur musunuz?

İndir ÖRNEK

Dosyayı indir ÖRNEK

dosya.co

 

[YUSUF44]

"Eğer kayıt varsa üzerine kayıt olacak" ifadesinden kastınız nedir? Örneğin Ali zaten Au sütununda varsa Ali olan hücreye tekrar Ali mi yazılacak? Neden, saçma olmaz mı?

 

[ormann]

Yusuf bey merhabalar,
Aynen o şekilde olacak.Örnegin : Ali,Veli,Ahmet yazıp,tekrar Ali yazdıgimda Ahmet'in sonuna tekrar Ali yazmayacak.

 

[YUSUF44]

Yani Ali varsa listede değişiklik olmayacak değil mi?

 

[ormann]

Olmayacak

 

[YUSUF44]

Aşağıdaki makroyu deneyiniz:

Sub aktar()
Set s1 = Sheets("Dikili Girişi")
son = WorksheetFunction.Max(3, s1.Cells(Rows.Count, "AU").End(3).Row)
If s1.[T9] = "" Then
    MsgBox "Lütfen önce cins giriniz!", vbCritical
    s1.Activate
    s1.[T9].Select
ElseIf WorksheetFunction.CountIf(s1.Range("AU3:AU" & son), s1.[T9]) > 0 Then
    MsgBox "Daha önce kaydedilmiş!", vbCritical
    s1.Activate
    s1.[T9].Select
Else
    s1.Cells(son + 1, "AU") = s1.[T9]
End If
End Sub

 

[ormann]

Teşekkür ederim. Yusuf bey

 

[ormann]

Yusuf bey veri aktarımını AU4:AU20 arasında sınırlayabilirmiyiz ?

 

[YUSUF44]

Aşağıdaki gibi deneyin:

Sub aktar()
Set s1 = Sheets("Dikili Girişi")
son = WorksheetFunction.Max(3, s1.Cells(Rows.Count, "AU").End(3).Row)
If s1.[T9] = "" Then
    MsgBox "Lütfen önce cins giriniz!", vbCritical
    s1.Activate
    s1.[T9].Select
ElseIf WorksheetFunction.CountIf(s1.Range("AU3:AU20"), s1.[T9]) > 0 Then
    MsgBox "Daha önce kaydedilmiş!", vbCritical
    s1.Activate
    s1.[T9].Select
ElseIf WorksheetFunction.CountBlank(s1.Range("AU3:AU20")) > 0 Then
    Set c = s1.Range("AU3:AU20").Find("")
    If Not c Is Nothing Then
        a = c.Row
        s1.Cells(a, "AU") = s1.[T9]
    End If
Else
    MsgBox "AU3:AU20 aralığında boş hücre bulunmadığından işlem yapılmadı!", vbInformation
End If
End Sub

 

[ormann]

Yusuf bey çok teşekkür ederim