Çözüldü 4 sütuna göre Mükerrer Kontrol

[sirkülasyon]

Değerli üstadlarım;
B sütunu (B2:B350) Ad Soyad
C sutunu (C2:C350) 0(000) 000 00 00 formatında Cep Telefonu
D Sütunu (D2 : D350) TC Kimlik No
G Sütunu (G2:G350) Araç Plaka No

Yukarıda arz ettiğim şekilde olan sütunların dördüne birden bakacak Mükerrer var ise Önce Sileyim mi diye soracak evet denilirse silecek, hayır denilirse renklendirecek bir makroya ihtiyacım var. Yardımcı olabilir misiniz?

Teşekkür eder saygılarımı sunarım.

 

[hamitcan]

Veri>Yinelenenleri Kaldır fonksiyonunu denediniz mi ?

 

[sirkülasyon]

Hamit Abi
Dediğinizi yapmıştım. Yinelenenleri sildi. O yüzden siteye döndüm abi

 

[halit3]

Sorun çözüldümü ?

 

[sirkülasyon]

Halit abi
Aynı sıkıntı devam ediyor. Çıktısını aldım mükerrer olanları belirledim. Ama formül ya da makro olarak henüz çözülmedi.
İlginiz içinde teşekkür ederim abi.

 

[halit3]

bir örnek dosya ekleyiniz silme derken hücreni silinecek satırmı silinecek yaksa silinenler ödelenecekmi?

 

[sirkülasyon]

Halit abi;
Vallahi örnek dosya ekleme durumu bira zor. Ama şöyle abime ifade edeyim.
B sütunu (B2:B350) Ad Soyad
C sutunu (C2:C350) 0(000) 000 00 00 formatında Cep Telefonu
D Sütunu (D2 : D350) TC Kimlik No
G Sütunu (G2:G350) Araç Plaka No yazılı

Benim acizane istirhamım şu:
4 Sütun da mükerrer var ise ilkönce soracak (Sileyim mi diye) Evet denilirse silecek. Hayır denilirse ne kadar mükerrer kayıt var ise o satırı renklendirecek.

 

[halit3]

evet deyince neyi silecek hücreyimi silecek yoksa bütün satırımı silecek

 

[sirkülasyon]

Halit abi
Mükerrer kayıdı sileyim mi diye sorulduğunda evet denilir ise mükerrer kaç tane var ise silecek.
Hayır denilirse Kaç tane mükerrer var ise renklendirecek.

 

[halit3]

Merhaba

üç mesajdır yazıyorum sorumu okuyormusunuz
kod yazılır orada sıkıntı yok siz sorulan sorulara cevap veriniz.

şimdi örnek verirsek

B3,C3.D3.E3
İLE

B5.C5.D5.E5

Hücreleri aynı olursa herhalse B5,C5,D5,E5 hücreleri silinecek tam da soru burada bu hücreler silinirken
1. Hücre değeri silinecek yani B5,C5,D5,E5 hücrelerinin içi boşaltılacak.
2. excelin sol tarafındaki sayısal değerlerine denk gelen 5. satır silinecek
3. B5,C5,D5,E5 hücreleri silinecek ve A5,F5,G5,H5,I5.J5 vb hücreler silinmeden B5,C5,D5,E5 bu hücreler silinecek ve yukarı hücreler ötelenecek


1. örnek Range("B55").Value = ""
2. örnek Range("B55").Delete Shift:=xlUp
3. örnek Rows("5:5").Delete Shift:=xlUp

silme kodları

 

[sirkülasyon]

Halit Abi
Bir önceki satır ile bir sonraki satırlardan herhangi birinin mükerrer olması halinde kaç tane mükerrer var ise ilk yazılan satır duracak diğerlerinin tamamı satır olarak silinecek.
Öteleme ise
Satır komple silindiğinden dolayı altta kalan satırlar üste doğru ötelenecek.

 

[halit3]

kod:

Sub Sil()
Application.ScreenUpdating = False

son = Cells(Rows.Count, "b").End(3).Row

Range("B2:E" & son).Interior.ColorIndex = xlNone

ReDim ara1(son): ReDim ara2(son): ReDim ara3(son)

For t = 2 To son
ara1(t) = Cells(t, "b") & Cells(t, "c") & Cells(t, "d") & Cells(t, "e")
ara2(t) = 1
ara3(t) = 2
Next


For i = 2 To son

For j = 2 To son
bulunan = Cells(j, "b") & Cells(j, "c") & Cells(j, "d") & Cells(j, "e")

If ara2(j) = 1 Then
If ara1(i) = bulunan Then
say = say + 1
If say > 1 Then
ara2(j) = 0
a = MsgBox(Cells(j, "b") & Chr(10) & " silmek istiyormusunuz..?", vbYesNo + vbInformation, " UYARI penceresi")
If a = vbYes Then
Cells(j, "g") = say
ara3(j) = 0
End If
If a = vbNo Then
Range(Cells(j, "b"), Cells(j, "e")).Interior.ColorIndex = 40
Range(Cells(i, "b"), Cells(i, "e")).Interior.ColorIndex = 40
End If

End If
End If
End If

Next j
say = 0
Next i


For k = son To 2 Step -1
If ara3(k) = 0 Then
Rows(k).Delete Shift:=xlUp
End If
Next

Application.ScreenUpdating = True
MsgBox "işlem tamam"
End Sub

 

[sirkülasyon]

Halit Abi
Gösterdiğiniz ilgiye, alakaya ve yardımınıza teşekkür ederim. Zahmet verdiğim için de hakkınızı helal edin.
Saygılarımla

 

[halit3]

Kodları çalıştırabildinizmi ? Sorun çözüldümü ?

 

[sirkülasyon]

Halit abi
B, C, D, sütunlarına göre mükerrer uyarısı yapıyor.
B, C, D, aynı ama plaka ((G) Sütunu) farklı mükerrer değil
B, C, D ve G aynı ise mükerrer uyarısı verse diye yazacaktım ama utandım daha yazamadım. 14' üncü mesaja istinaden yazdım. Hakkını helal et abi.
Saygı ve Hürmetlerimle

 

[halit3]

Herkes cevap vermekten kaçınıyor örnek dosya ekleseniz böyle olmaz
Yardım etmeye çalışıyoruz örnek dosyayı bile biz oluşturuyoruz.
1. nolu mesajınızdaki dosyaya soruya göre ben kendim oluşturduğum dosyada denedim olumlu sonuç aldım.

 

[sirkülasyon]

Halit abi dosya ekte.

 

[halit3]

kod:

Sub Sil()
Application.ScreenUpdating = False

son = Cells(Rows.Count, "b").End(3).Row

Range("B2:E" & son).Interior.ColorIndex = xlNone

ReDim ara1(son): ReDim ara2(son): ReDim ara3(son)

For t = 2 To son
ara1(t) = Cells(t, "b") & Cells(t, "c") & Cells(t, "d") & Cells(t, "g")
ara2(t) = 1
ara3(t) = 2
Next


For i = 2 To son

For j = 2 To son
bulunan = Cells(j, "b") & Cells(j, "c") & Cells(j, "d") & Cells(j, "g")

If ara2(j) = 1 Then
If ara1(i) = bulunan Then
say = say + 1
If say > 1 Then
ara2(j) = 0
a = MsgBox(Cells(j, "b") & Chr(10) & " silmek istiyormusunuz..?", vbYesNo + vbInformation, " UYARI penceresi")
If a = vbYes Then
Cells(j, "g") = say
ara3(j) = 0
End If
If a = vbNo Then
Range(Cells(j, "b"), Cells(j, "e")).Interior.ColorIndex = 40
Range(Cells(i, "b"), Cells(i, "e")).Interior.ColorIndex = 40
End If

End If
End If
End If

Next j
say = 0
Next i


For k = son To 2 Step -1
If ara3(k) = 0 Then
Rows(k).Delete Shift:=xlUp
End If
Next

Application.ScreenUpdating = True
MsgBox "işlem tamam"
End Sub

 

[sirkülasyon]

Ellerinden Öperim. Halit abi
Var olasın.
Teşekkür eder, saygılarımı sunarım.

 

[halit3]

Sorunuz çözüldü değilmi
iyi çalışmalar