• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

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

A

acolkesen1

Katılım
5 Aralık 2007
Mesajlar
635
Excel Vers. ve Dili
Office 2007
Merhaba sevgili dostlar.Günde kaç soru hakkımız var acaba..:D 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..
 
Aşağıdaki kodu çalışma sayfasının kod bölümüne yazınız.:cool:
Kod: 
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
 
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.
 
acolkesen1' Alıntı:
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.
Genişletmek için tıkla ...
Bir örnek dosya ekleyiniz.
Üzerine birkaçtane veri giriniz.
Dosya üzerinde göstererek soruyu yazınız.:cool:
 
Ekli dosyayı inceleyiniz.:cool:
Kod: 
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
 
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..
 
acolkesen1' Alıntı:
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..
Genişletmek için tıkla ...

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.:cool:
 
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.
 
Bir örnek dosya üzerinde açıklamalı olarak gösteriniz.:cool:
 
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..:)
 
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..
 
Ekli dosyayı inceleyiniz.:cool:
Kod: 
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
 
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..
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst