mükerrer kayıt yazılmasın ama ilk kaydın karşısına toplasın

[acolkesen1]

Merhaba sevgili dostlar.Günde kaç soru hakkımız var acaba.. Sorunum şu; A:A sütununa girdiğimiz verilerden mükerrer olanı yazılmasın ancak B:B sütununda ilk kaydın karşısına toplasın. Yeni kayıt mükerrer değilse yazsın. Mümkün mü acaba..

 

[Orion1]

Aşağıdaki kodu çalışma sayfasının kod bölümüne yazınız.

Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo hata
If Intersect(Target, [A:A]) Is Nothing Then Exit Sub
If WorksheetFunction.CountIf(Range("A1:A65536"), Target.Value) >= 2 Then
    Target.Value = Empty
    Target.Select
End If
hata:
End Sub

 

[acolkesen1]

Sevgili Orion2, herzaman hızır gibi yetişiyorsunuz.. Ancak toplamları nereye alıyor anlayamadım.Ben A:A sütununun karşısına ,yani B:B sütununda mükerrer kaydın karşısına toplasın istiyordum.

 

[Orion1]

Sevgili Orion2, herzaman hızır gibi yetişiyorsunuz.. Ancak toplamları nereye alıyor anlayamadım.Ben A:A sütununun karşısına ,yani B:B sütununda mükerrer kaydın karşısına toplasın istiyordum.

Bir örnek dosya ekleyiniz.
Üzerine birkaçtane veri giriniz.
Dosya üzerinde göstererek soruyu yazınız.

 

[acolkesen1]

Örnek ektedir.

 

[Orion1]

Ekli dosyayı inceleyiniz.

Private Sub Worksheet_Change(ByVal Target As Range)
Dim a, k As Range
On Error GoTo hata
If Intersect(Target, [A:A]) Is Nothing Then Exit Sub
If WorksheetFunction.CountIf(Range("A1:A65536"), Target.Value) >= 2 Then
    a = Target.Value
    Target.Value = Empty
    Target.Select
    Set k = Range("A1:A65536").Find(a, , xlValues, xlWhole)
    If Not k Is Nothing Then
        Cells(k.Row, "B").Value = Cells(k.Row, "B") + 1
    End If
End If
hata:
Set k = Nothing
End Sub

 

[acolkesen1]

Yine jet hızıyla cevap...Teşekkürler Orion2..Bir ilave daha yapabilirmiyiz.? Bu kodla ikinci mükerrer kayıttan sonra topluyor.Yani ikinci "a" yı yazdıktan sonra birinci "a" nın karşına 1 yazıyor, oysa birinciyle ikinci yazdığımı toplamalı..Koddaki 1 i 2 yaptım ama bu seferde ikişer ikişer topluyor doğal olarak. Şimdiden teşekkürler..

 

[Orion1]

Yine jet hızıyla cevap...Teşekkürler Orion2..Bir ilave daha yapabilirmiyiz.? Bu kodla ikinci mükerrer kayıttan sonra topluyor.Yani ikinci "a" yı yazdıktan sonra birinci "a" nın karşına 1 yazıyor, oysa birinciyle ikinci yazdığımı toplamalı..Koddaki 1 i 2 yaptım ama bu seferde ikişer ikişer topluyor doğal olarak. Şimdiden teşekkürler..

Yani ikinci a 'yı yazdınız ,sonrada karşısındaki b sütununa bir rakam yazdınız.B sütunundaki rakamla ilk a daki b sütunundaki rakamımı toplasın.

 

[acolkesen1]

sevgili Orion2 , bu saatte size yük oluyor duygusuna kapılıyorum ama, yapmak istediğim şu; sadece a sütununa veri giriyorum. B sütununa ise A sütununa ilk yazdığım verinin karşısına diğer yazdığım mükerrer verileri kendiliğinden toplasın.Gönderdiğiniz örnek iş görüyor ama B sütununa ilk verinin karşına b sütununa 1 yazmak gerekiyor.Veya şöyle olabilir mi; veri ilk girildiğinde karşısına otomatik olarak 1 yazsın,diğerlerini de bunun üzerine toplasın.

 

[Orion1]

Bir örnek dosya üzerinde açıklamalı olarak gösteriniz.

 

[acolkesen1]

Sevgili orion2, bu işi formül kullanmadan çözmek istemiştim ama, b1 hücresine formül yazıp gerektiği kadar çoğaltarak hallettim. Gerisini de sizin kodlar hallediyor zaten..İlginize çok teşekkür ederim. Ancak kodla çözülmesi durumunda da reddetmem doğrusu..İyi geceler..

 

[acolkesen1]

yaptığım çalışma ekteki gibi. Yalnız mükerrer veri girilince kod devreye girdiği için b sütunundaki formül siliniyor doğal olarak..

 

[Orion1]

Ekli dosyayı inceleyiniz.

Private Sub Worksheet_Change(ByVal Target As Range)
Dim a, k As Range
On Error GoTo hata
If Intersect(Target, [A:A]) Is Nothing Then Exit Sub
If WorksheetFunction.CountIf(Range("A1:A65536"), Target.Value) >= 2 Then
    a = Target.Value
    Target.Value = Empty
    Target.Select
    Set k = Range("A1:A65536").Find(a, , xlValues, xlWhole)
    If Not k Is Nothing Then
        If Cells(k.Row, "B").Value = 0 Then
            Cells(k.Row, "B").Value = 2
            Else
            Cells(k.Row, "B").Value = Cells(k.Row, "B") + 1
        End If
    End If
End If
hata:
Set k = Nothing
End Sub

 

[acolkesen1]

Elinize sağlık..Sanırım ben zor anlattım..Sizin için çok kolay olsa gerek..Tekrar teşekkür ederim..Beni mutlu ettiniz..

 

[Orion1]

Elinize sağlık..Sanırım ben zor anlattım..Sizin için çok kolay olsa gerek..Tekrar teşekkür ederim..Beni mutlu ettiniz..

Rica ederim.
İyi çalışmalar.
Oldumu?Merak ettimde.

 

[acolkesen1]

Evet, tam olması gerektiği gibi..

 

[Orion1]

Evet, tam olması gerektiği gibi..

Anlaşıldı.
Tamam.