4 şartlı mükerrer kayıt

[orcunerkek54]

açıklamaları ekteki dosyada yapmaya çalıştım...bunu personel kayıt veya malzeme depolama gibide düşünebiliriz......... herkeze teşekkürler

 

[orcunerkek54]

arkadaşlar aynı sorumu biraz değiştirerek tekrar sormak istiyorum . bu örneğim eski sorumu karşılamıyor ama işimi görür heralde öteki oldukça zor galiba...

 

[Ali]

İlgili sayfanıza aşağıdaki kodları ekleyin. 5000 olan kısımı satır sayınıza göre kendinize göre düzenlersiniz.

Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
If Intersect(Target, [D2:F5000]) Is Nothing Then Exit Sub
satirlar = Application.WorksheetFunction.CountIf([D2:F5000], Target)
If satirlar > 1 Then
Target.Select
Target.Value = ""
Exit Sub
End If
End Sub

 

[orcunerkek54]

syn ali bey ilginiz ve yardımınız için teşekkürler...kodlarınız gayet güzel çalıştı ancak sizden bir ilave daha etmenizi isteyebilirmiyim.plaka hanesini değiştirdiğimizde kaydı yapmıyor..ben istiyorumki b süyunu değiştiğinde diğerleri aynı olsada kaydı yapsın.. yardımcı olursanız sevinirim iyi akşamlar teşekkürler

 

[Ali]

B sütunu farklı ise silmez.

Sub mükerrersil()
For i = 2 To 5000
Cells(i, 256) = Cells(i, 2) & Cells(i, 4) & Cells(i, 5) & Cells(i, 6)
Next
For a = [IV65536].End(3).Row To 1 Step -1
If WorksheetFunction.CountIf(Range("IV1:IV" & a), Cells(a, "IV")) > 1 Then Rows(a).Delete
Next
Columns("IV:IV").ClearContents
End Sub

 

[Ali]

Eski kodda IV sütununu kullandırdım
For Each ile daha hızlı çalışıyor

Sub dörtlüsil()
Dim k
Dim benzer As Range
Dim satirlar As Integer
satirlar = 0
On Error Resume Next
    For Each benzer In Range("D1:" & "D" & Range("D5000").End(3).Row)
git:            For k = 2 To Range("D5000").End(3).Row
            If benzer = Range("D" & k + satirlar) And benzer.Offset(0, 1) = Range("E" & k + satirlar) And benzer.Offset(0, 2) = Range("F" & k + satirlar) And benzer.Offset(0, -2) = Range("B" & k + satirlar) Then
               Range("D" & k + satirlar).EntireRow.Delete
               GoTo git
            End If
            Next
        satirlar = satirlar + 1
    Next
End Sub

 

[orcunerkek54]

syn ali bey yardımınız için çok teşekkürler kodunuz gayet güzel çalışıyor ve yıldırım gibi çalışıyor ) emeğinize sağlık...

 

[orcunerkek54]

syn ali bey tekrar merhaba kodlarınızda değişiklik yapmaya çalıştım ama yapamadım.sadece sutun yerlerini değiştirmek yaterli değil galiba değiştirdiğim kod şu sekilde
Private Sub CommandButton1_Click()
kayıt = ActiveWorkbook.Sheets("malzemekayıt").Range("a65536").End(xlUp).Row + 1
Sheets("malzemekayıt").Cells(kayıt, 1) = ComboBox1.Text
Sheets("malzemekayıt").Cells(kayıt, 3) = ComboBox2.Text
Sheets("malzemekayıt").Cells(kayıt, 4) = ComboBox3.Text
Sheets("malzemekayıt").Cells(kayıt, 8) = ComboBox4.Text

Dim k
Dim benzer As Range
Dim satirlar As Integer
satirlar = 0
On Error Resume Next
For Each benzer In Range("c1:" & "c" & Range("c5000").End(3).Row)
git: For k = 1 To Range("c5000").End(3).Row
If benzer = Range("c" & k + satirlar) And benzer.Offset(0, 1) = Range("d" & k + satirlar) And benzer.Offset(0, 2) = Range("h" & k + satirlar) And benzer.Offset(0, -2) = Range("a" & k + satirlar) Then
Range("c" & k + satirlar).EntireRow.Delete
GoTo git
End If
Next
satirlar = satirlar + 1
Next
End Sub

kaydederken sıra numarası vermiyorum

buradaki hatamı düzeltebilirseniz sevinirim..teşekkürler

 

[Ali]

benzer.Offset(0, 2) = Range("h" & k + satirlar) olan kısımı

benzer.Offset(0, 5) = Range("h" & k + satirlar) olarak yapıp denermisiniz.

 

[orcunerkek54]

syn ali bey sayfayı durmaksızın siliyor belirtilen değişiklik yapılınca

 

[Ali]

2 mesajınızda eklediğiniz dosyanın içindeki tüm kodları silin ve Userformun Command butonuna aşağıdaki kodları ekleyin.

Private Sub CommandButton1_Click()
Dim k
Dim benzer As Range
Dim satirlar As Integer
say = Application.CountA(Sheets("Sayfa1").Columns("A"))
TextBox1.Text = Sheets("Sayfa1").Cells(say, 1) + 1
kayıt = ActiveWorkbook.Sheets("Sayfa1").Range("a65536").End(xlUp).Row + 1
sira = TextBox1.Text
Sheets("Sayfa1").Cells(kayıt, 1) = TextBox1.Text
Sheets("Sayfa1").Cells(kayıt, 2) = ComboBox1.Text
Sheets("Sayfa1").Cells(kayıt, 4) = ComboBox2.Text
Sheets("Sayfa1").Cells(kayıt, 5) = ComboBox3.Text
Sheets("Sayfa1").Cells(kayıt, 6) = ComboBox4.Text
TextBox1.Text = sira + 1
satirlar = 0
On Error Resume Next
    For Each benzer In Range("D1:" & "D" & Range("D5000").End(3).Row)
git:            For k = 2 To Range("D5000").End(3).Row
            If benzer = Range("D" & k + satirlar) And benzer.Offset(0, 1) = Range("E" & k + satirlar) And benzer.Offset(0, 2) = Range("F" & k + satirlar) And benzer.Offset(0, -2) = Range("B" & k + satirlar) Then
               Range("D" & k + satirlar).EntireRow.Delete
               GoTo git
            End If
            Next
        satirlar = satirlar + 1
    Next
End Sub

 

[orcunerkek54]

syn ali bey kodlarınız çalışıyor ancak her nedense kendime uyarlayamadım kodlarınızı aşağıdaki kayıt koduna göre ayarlayabilirmisiniz ben değiştirme yapınca sürekli silmeye başlıyor.... teşekkürler

kayıt = ActiveWorkbook.Sheets("Sayfa1").Range("a65536").End(xlUp).Row + 1
Sheets("Sayfa1").Cells(kayıt, 1) = ComboBox1.Text
Sheets("Sayfa1").Cells(kayıt, 3) = ComboBox2.Text
Sheets("Sayfa1").Cells(kayıt, 4) = ComboBox3.Text
Sheets("Sayfa1").Cells(kayıt, 8) = ComboBox4.Text

 

[orcunerkek54]

sıra numarası kullanmıyorum söylemeyi unutmuşum )

 

[Ali]

Sürekli değiştirdiğiniz için tekrar düzenlemek zorunda kalıyorum.Verileriniz hangi sütunlara yazılacak,hangi sütunlar farklı olduğunda yazılacak,hangi sütunlar eşit olduğunda silinecek.

 

[Ali]

Sanırım C,D ve H sütunlarına yazdırmak istiyorsunuz C,D, ve H sütunları eşit,A sütunundaki farklı olursa kaydeder. A sütununda bulunan değerde eşit olursa onu kaydetmez.

Private Sub CommandButton1_Click()
Dim k
Dim benzer As Range
Dim satirlar As Integer
kayıt = ActiveWorkbook.Sheets("Sayfa1").Range("a65536").End(xlUp).Row + 1
Sheets("Sayfa1").Cells(kayıt, 1) = ComboBox1.Text
Sheets("Sayfa1").Cells(kayıt, 3) = ComboBox2.Text
Sheets("Sayfa1").Cells(kayıt, 4) = ComboBox3.Text
Sheets("Sayfa1").Cells(kayıt, 8) = ComboBox4.Text
satirlar = 0
On Error Resume Next
    For Each benzer In Range("C1:" & "C" & Range("C5000").End(3).Row)
git:            For k = 2 To Range("C5000").End(3).Row
            If benzer = Range("C" & k + satirlar) And benzer.Offset(0, 1) = Range("D" & k + satirlar) And benzer.Offset(0, 5) = Range("H" & k + satirlar) And benzer.Offset(0, -2) = Range("A" & k + satirlar) Then
               Range("C" & k + satirlar).EntireRow.Delete
               GoTo git
            End If
            Next
        satirlar = satirlar + 1
    Next
End Sub

 

[orcunerkek54]

syn ali bey yardımınız için çok teşekkürler...şu an kodlarınızı kullanıyorum verdiğiniz kodlarınız çalışıyor.kullanma amacımı tam karşılamıyorlar ama benim sizden istediğimi karşılıyor.tekrar teşekkürler...
aslında benim istediğim biraz karışık gibi birşey yapılabilirmi bilmiyorum.. dosyamıda ekliyorum ona bakabilirseniz sevinirim...