Aynı olan satırları silmek

[katip16487]

(9) nolu mesajdaki kodu uygulamaya çalışıyorum, ancak istediğim sonucu alamıyorum, yine 1 tanesini bırakıp mükerrerleri siliyor.

A sütununda A2:A65536 arasında tarama yaptıktan sonra mükerrer bulduğu tüm kayıtları silecek şekilde makroyu uyarlayabilirseniz sevinirim.

Yani, 3 tane 11, 2 tane 33, 1 tane de 5 varsa, sadece 5 kalsın, diğerleri silinsin.

Saygılarımla...

 

[halit3]

(9) nolu mesajdaki kodu uygulamaya çalışıyorum, ancak istediğim sonucu alamıyorum, yine 1 tanesini bırakıp mükerrerleri siliyor.

A sütununda A2:A65536 arasında tarama yaptıktan sonra mükerrer bulduğu tüm kayıtları silecek şekilde makroyu uyarlayabilirseniz sevinirim.

Yani, 3 tane 11, 2 tane 33, 1 tane de 5 varsa, sadece 5 kalsın, diğerleri silinsin.

Saygılarımla...

kod:

Sub sil()

ZBasla = TimeValue(Now)
zaman = Timer
sut1 = "A" 'başlangıç sutün
sat1 = 2 'başlangıç satır

Application.ScreenUpdating = False

Set Sh1 = Sheets(ActiveSheet.Name) 'sayfa adı
son = Sh1.Cells(Rows.Count, sut1).End(3).Row 'son dolu satır
Sh1.Range(Sh1.Cells(sat1, sut1), Sh1.Cells(son, sut1)).Interior.ColorIndex = xlNone

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

For j = sat1 To son
ara1(j) = Sh1.Cells(j, sut1) & Sh1.Cells(j, 2)
ara2(j) = 1
Next j

For r = sat1 To son
aranan1 = ara1(r)

If ara2(r) = 1 Then
say1 = 0
For i = r To son
If ara1(i) = aranan1 Then
ara2(i) = 0
say1 = say1 + 1
ara3(say1) = i
End If
Next i

If say1 > 1 Then
For m = 1 To say1
Sh1.Cells(ara3(m), sut1).Interior.ColorIndex = 6
Next
End If
sat1 = sat1 + 1
End If
Next r

sat1 = 2 'başlangıç satır
For t = son To sat1 Step -1
If Sh1.Cells(t, 1).Interior.ColorIndex = 6 Then
Rows(t).Delete Shift:=xlUp
End If
Next t

Application.ScreenUpdating = True

zBitis = TimeValue(Now)
MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & _
"İşlem süresi ; " & Format(Timer - zaman, "0.00") & Chr(10) & _
"Geçen Süre " & CDate(zBitis - ZBasla), vbInformation, " Sonuç Penceresi"

End Sub

 

[muarrem]

Arkadarlar bunu stunda degilde satirda naisl yapabiliriz