• DİKKAT

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

Mükerrer kayıt

  • Konbuyu başlatan Konbuyu başlatan m.gur
  • Başlangıç tarihi Başlangıç tarihi
M

m.gur

Katılım
9 Temmuz 2004
Mesajlar
427
Excel Vers. ve Dili
Office 2007 Tr & Office 2019 Tr
Merhaba;
Öncelikle forumda arama yaptığımı belirteyim. O kadar çok örnek var ki hiçbirini dosyama uyalıyamadım. Girdiğim değer daha önce girilmişsse uyarıda bulunacak, hem renkle hem de mesajla bildirecek (mesajda ...nolu satırda kayıtlı) demesi tercihimdir. Değerin biri silindiğinde renk kaybolacak. Dosya ekte. Teşekkürler.
 

Ekli dosyalar

Son düzenleme:
Mükerrer kaydı engellemek mi istiyorsunuz; yoksa mükerrere izin vermesini, sonradan kendiniz mi silmek istiyorsunuz?
 
sayfanın kod bölümüne ekleyin iyi çalışmalar.

Private Sub Worksheet_Change(ByVal Target As Range)
For a = [a65536].End(3).Row To 1 Step -1
If WorksheetFunction.CountIf(Range("a1:a" & a), Cells(a, "a")) > 1 Then
Cells(a, "a").Interior.ColorIndex = 6
Cells(a, "c").Interior.ColorIndex = 6
MsgBox "bu kayıt daha önce işlendi.."
Else
Cells(a, "a").Interior.ColorIndex = 15
Cells(a, "c").Interior.ColorIndex = 2
End If
Next
End Sub
 
Diyelim ki ben 3 üncü tabloya kayıt girerken aynı şahsı daha önce girmişsem o şahsa ait bilgileri girmeye önceki kayıttan devam edeceğim ve son girdiğimi sileceğim. Biraz şöyle açıklama yapayım; ben bu tabloyu fazla mesaisi olan şahısların hangi günlerde ne kadar mesai yaptıklarını tutuyorum. Bana gelen bilgiler peyderpey geldiği için aynı şahıs 3-5 defa yazılabiliyor. Bilgileri ayrı ayrı yerlerde olmasın sadece bir tabloda olsun istiyorum. Umarım anlatabilmişimdir.
 
İstediğiniz böyle bir şey mi? Silme kodunu ona göre yapacağım.
 

Ekli dosyalar

Sayın fedeal;
Öncelikle teşekkür ederim. Aynı kayıdı sildiğimde renk kaybolmuyor, ancak yerine başka kayıt girdiğimde kayboluyor. Bir de hangi satırda kayıtlı olduğunu buldurabilirmiyiz. Teşekkürler.
 
Private Sub Worksheet_Change(ByVal Target As Range)
For a = [a65536].End(3).Row To 1 Step -1
If WorksheetFunction.CountIf(Range("a1:a" & a), Cells(a, "a")) > 1 Then
Cells(a, "a").Interior.ColorIndex = 6
Cells(a, "c").Interior.ColorIndex = 6
On Error Resume Next
i = [a65536].End(3).Row
t = WorksheetFunction.Match(Cells(i, 1).Value, Range("a2:a" & i - 1), 0)
MsgBox "bu kayıt " & t & " nolu satırda daha önce işlendi.."
Else
Cells(a, "a").Interior.ColorIndex = 15
Cells(a, "c").Interior.ColorIndex = 2
End If
Next
End Sub
kayıtlı satırı gösteriyor öteki hataya bakıyorum.
 
Evet böyle. Teşekkürler.
 
Private Sub Worksheet_Change(ByVal Target As Range)
For a = [a65536].End(3).Row To 1 Step -1
If ActiveCell.Value = "" Then
ActiveCell.Interior.ColorIndex = 15
i = [a65536].End(3).Row + 1
Cells(i, 3).Interior.ColorIndex = 2
End If
If WorksheetFunction.CountIf(Range("a1:a" & a), Cells(a, "a")) > 1 Then
Cells(a, "a").Interior.ColorIndex = 6
Cells(a, "c").Interior.ColorIndex = 6
On Error Resume Next
i = [a65536].End(3).Row
t = WorksheetFunction.Match(Cells(i, 1).Value, Range("a2:a" & i - 1), 0)
MsgBox "bu kayıt " & t & " nolu satırda daha önce işlendi.."
Else
Cells(a, "a").Interior.ColorIndex = 15
Cells(a, "c").Interior.ColorIndex = 2
End If
Next
End Sub

bundada silince renk düzeliyor,iyi çalışmalar.
 
Çok teşekkür ederim. Saygılar.
 
fedeal' Alıntı:
Private Sub Worksheet_Change(ByVal Target As Range)
For a = [a65536].End(3).Row To 1 Step -1
If ActiveCell.Value = "" Then
ActiveCell.Interior.ColorIndex = 15
i = [a65536].End(3).Row + 1
Cells(i, 3).Interior.ColorIndex = 2
End If
If WorksheetFunction.CountIf(Range("a1:a" & a), Cells(a, "a")) > 1 Then
Cells(a, "a").Interior.ColorIndex = 6
Cells(a, "c").Interior.ColorIndex = 6
On Error Resume Next
i = [a65536].End(3).Row
t = WorksheetFunction.Match(Cells(i, 1).Value, Range("a2:a" & i - 1), 0)
MsgBox "bu kayıt " & t & " nolu satırda daha önce işlendi.."
Else
Cells(a, "a").Interior.ColorIndex = 15
Cells(a, "c").Interior.ColorIndex = 2
End If
Next
End Sub

bundada silince renk düzeliyor,iyi çalışmalar.
Genişletmek için tıkla ...


Bir şey daha rica edebilirmiyim acaba?
Mükerrer kayıdı renklendirirken önceki aynı kaydı da renklendirse diyorum. Eğer o da olursa çok daha güzel olacak. Şimdiden teşekkürler.
 
Private Sub Worksheet_Change(ByVal Target As Range)
For a = [a65536].End(3).Row To 1 Step -1
If ActiveCell.Value = "" Then
ActiveCell.Interior.ColorIndex = 15
i = [a65536].End(3).Row + 1
Cells(i, 3).Interior.ColorIndex = 2
End If
If WorksheetFunction.CountIf(Range("a1:a" & a), Cells(a, "a")) > 1 Then
Cells(a, "a").Interior.ColorIndex = 6
Cells(a, "c").Interior.ColorIndex = 6
On Error Resume Next
i = [a65536].End(3).Row
t = WorksheetFunction.Match(Cells(i, 1).Value, Range("a2:a" & i - 1), 0)
Cells(t + 1, "a").Interior.ColorIndex = 6
Cells(t + 1, "c").Interior.ColorIndex = 6
MsgBox "bu kayıt " & t & " nolu satırda daha önce işlendi.."
Else
Cells(a, "a").Interior.ColorIndex = 15
Cells(a, "c").Interior.ColorIndex = 2
End If
Next
End Sub
Genişletmek için tıkla ...

iyi çalışmalar.
 
Sayın fedeal; sabahtan beri deniyorum. Makrolara ekleme yapıyorum değiştiriyorum ama beceremedim. Sizi tekrar yormayayım dedim ama olmadı. İsteğim şuydu son yazdığım mükerrer kayıt ve ondan önceki renkleniyor ya, ben istiyorum ki ilk kayıtta gerekli bilgileri düzenleyeyim daha sonra son kayıdı sileyim ilk kaydın rengi o zaman değişsin. Nedeni ise şu, listem uzun olduğu için bulma kolaylığı olsun diye. Teşekkür ederim.
 
Private Sub Worksheet_Change(ByVal Target As Range)
For a = [a65536].End(3).Row To 1 Step -1
If ActiveCell.Value = "" Then
ActiveCell.Interior.ColorIndex = 15
i = [a65536].End(3).Row + 1
Cells(i, 3).Interior.ColorIndex = 2
End If
If WorksheetFunction.CountIf(Range("a1:a" & a), Cells(a, "a")) > 1 Then
Cells(a, "a").Interior.ColorIndex = 6
Cells(a, "c").Interior.ColorIndex = 6
On Error Resume Next
i = [a65536].End(3).Row
t = WorksheetFunction.Match(Cells(i, 1).Value, Range("a2:a" & i - 1), 0)
Cells(t + 1, "a").Interior.ColorIndex = 6
Cells(t + 1, "c").Interior.ColorIndex = 6
MsgBox "bu kayıt " & t & " nolu satırda daha önce işlendi.."
GoTo fed
Else
Cells(a, "a").Interior.ColorIndex = 15
Cells(a, "c").Interior.ColorIndex = 2
End If
Next
fed:
End Sub
Genişletmek için tıkla ...
iyi çalışmalar.
 
Sayın fedeal; biliyorum çok oldum ama ne yapayım, yaptığım bir işin tam olmasını istiyorum. Son yazdığınız makrolarda ben gerekli düzeltmeleri yaparak dosyayı son şekline getirdim. Ancak mükerrer kayıtta gerekli bilgiyi girerken sizin de göreceğiniz gibi her girdiğim bilgi için mesaj çıkıyor. Onu da düzeltebilirmiyiz. Dosyayı o şekliyle ilk mesaja yeniden ekliyorum. Saygılar.
 
Evet ama kodlarla açıyorum onları incelerseniz.
 
yani mükerrer kayıtta uyarı versin mükerrer kayıdı silmeden yeniden giriş yaparsam uyarı vermesinmi diyorsunuz?
 
Burada yapmak istediğim şu; örnekteki Hasan adlı kişi C3 satırında yazılı. Şimdi ben verileri girerken C5 e Hasan yazdım fakat daha önce bu kişi yazıldı ancak yeni bilgilerini girmek zorundayım. C3 teki bilgileri kaldığım yerden yazmaya devam edersem, her girdiğim bilgiden sonra mesaj çıkıyor. Ben buraya bilgileri gireyim işim bitince son yazdığım yani C5 teki kayıdı sileyim
 

Ekli dosyalar

2 seçenek var gibi görünüyor kodları change olayına yazdıgımız için bu uyarıyı alcagız

1.mesajı iptal etmek
2.sadece a sütunu degişince uyarı almak

1.yi sizde yapabilirsiniz.
2. için kodları şöyle değiştirelim


Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 1 <> Empty Then Call fed
End Sub
Sub fed()
ActiveSheet.Unprotect ("333")
For a = [a65536].End(3).Row To 1 Step -1
If ActiveCell.Value = "" Then
ActiveCell.Interior.ColorIndex = 2
i = [a65536].End(3).Row + 1
Cells(i, 3).Interior.ColorIndex = 2
End If
If WorksheetFunction.CountIf(Range("a1:a" & a), Cells(a, "a")) > 1 Then
Cells(a, "a").Interior.ColorIndex = 6
Cells(a, "c").Interior.ColorIndex = 6
On Error Resume Next
i = [a65536].End(3).Row
t = WorksheetFunction.Match(Cells(i, 1).Value, Range("a1:a" & i - 1), 0)
Cells(t, "a").Interior.ColorIndex = 6
Cells(t, "c").Interior.ColorIndex = 6
MsgBox "Bu kayıt " & t & " nolu satırda daha önce işlendi.."
GoTo fed
Else
Cells(a, "a").Interior.ColorIndex = 2
Cells(a, "c").Interior.ColorIndex = 2
End If
Next
fed:
ActiveSheet.Protect ("333")
End Sub
Genişletmek için tıkla ...
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst