mükerrer olan olan kayıtları asıl kayıt ile birlikte silme

[sunkid]

Merhaba Arkadaşlar,
Mükerrer olan kayıtları silerken tüm kaydın silinmesini nasıl sağlayabilirim? Yani a1 de bursa yazıyor a6 da bursa yazıyor her iki kaydında silinmesini nasıl sağlarım?

 

[Emir Hüseyin Çoban]

. . .

Sub KOD()
    Application.ScreenUpdating = False
    Dim dizi()
    For i = 1 To Cells(Rows.Count, "A").End(3).Row
        If WorksheetFunction.CountIf(Range("A:A"), Cells(i, "A")) = 1 Then
            ReDim Preserve dizi(1, s)
            dizi(0, s) = Cells(i, "A").Value
            s = s + 1
        End If
    Next i
    Range("A:A").ClearContents
    If s <> 0 Then
        Range("A1").Resize(s, 2).Value = Application.Transpose(dizi)
    End If
    Application.ScreenUpdating = True
    MsgBox " B i t t i "
End Sub

. . .

 

[sunkid]

Üstad süpersin paylaşımın için çok teşekkür ederim. Peki şunu nasıl sağlayabiliriz. sadece A sütunu değilde A sütunundan H sütununa kadar olan kayıtların aynı (mükerrer) olması durumunda kayıtların silinmesi sağlayacak kodu nasıl yazabilirim?

 

[Emir Hüseyin Çoban]

. . .

Yardımcı sütun kullanılarak yapılabilir. Z sütunu kullanılmıştır.

Sub KOD()
    Application.ScreenUpdating = False
    
    Range("Z:Z").ClearContents
    [Z1] = "=A1 & B1 & C1 & D1 & E1 & F1 & G1 & H1"
    [Z1].AutoFill Destination:=Range("Z1:Z" & Cells(Rows.Count, "A").End(3).Row), Type:=xlFillDefault
    [Z:Z].Value = [Z:Z].Value
    
    Dim dizi()
    For i = 1 To Cells(Rows.Count, "A").End(3).Row
        If WorksheetFunction.CountIf(Range("Z:Z"), Cells(i, "Z")) = 1 Then
            ReDim Preserve dizi(7, s)
            dizi(0, s) = Cells(i, "A").Value
            dizi(1, s) = Cells(i, "B").Value
            dizi(2, s) = Cells(i, "C").Value
            dizi(3, s) = Cells(i, "D").Value
            dizi(4, s) = Cells(i, "E").Value
            dizi(5, s) = Cells(i, "F").Value
            dizi(6, s) = Cells(i, "G").Value
            dizi(7, s) = Cells(i, "H").Value
            s = s + 1
        End If
    Next i
    
    Range("Z:Z").ClearContents
    Range("A:H").ClearContents
    If s <> 0 Then
        Range("A1").Resize(s, 8).Value = Application.Transpose(dizi)
    End If
    Application.ScreenUpdating = True
    MsgBox " B i t t i "
    
End Sub

. . .

 

[sunkid]

hocam kod takır takır çalıyor eline sağlık. Peki neden Z sütununu kullandık? ilerde kriter yani kolon arttığında dizi(8, s) = Cells(i, "I").Value yazdığımda da kod çalışır mı?

 

[Emir Hüseyin Çoban]

. . .

Yardımcı bir alan gerekiyordu. Herhangi bir kullanılmayan sütun olabilirdi.

Şu 3 kısımda değişiklik yapmanız gerekir.

    [Z1] = "=A1 & B1 & C1 & D1 & E1 & F1 & G1 & H1[B][COLOR="Red"] & I1[/COLOR][/B]"
   [COLOR="Red"][B] dizi(8, s) = Cells(i, "I").Value[/B][/COLOR]
    Range("A:[COLOR="Red"][B]I[/B][/COLOR]").ClearContents
    Range("A1").Resize(s, [COLOR="Red"][B]9[/B][/COLOR]).Value = Application.Transpose(dizi)

. . .