aynı satırları silmek belli koşula göre

[tiranorex]

Arkadaşlar merhaba,
[02/01 00:28:03] [02/01 00:19:40]
[02/01 00:28:02] [02/01 00:19:40]
.
.
.
.
.

şeklinde devam eden 10.000 satırlık bir listem var. Bana gerekli olan aynı dakikada olmayan satırların silinmesi.(örneğin sadece 00.28.02 içeren satır kalacak) 10.000 satırın 500 satıra kadar geldim ama artık ekranı çift görmeye başladım. Bu konuda yardımcı olabilecek varsa çok sevinirim.

 

[Levent Menteşoğlu]

Dosyanızdan bir kaç yüz veri içeren bir örneğini eklermisiniz.

 

[tiranorex]

Hocam_örnek dosyayı ekledim

Hocam örnek olarak istediğiniz dosyayı ekledim.

 

[Orion1]

Benzer leri b sütununa listeler.Miktarlarınıda c sütununa .
Dosyanız ekte.

Sub mükerrer()
Dim a, n As Long, i As Long, z As Object
Set s1 = Sheets("Sheet1")
'*******************************************************
Sheets("Sheet1").Select
Range("B1:c65536").Clear
a = s1.Range("A1:A" & Cells(65536, "A").End(xlUp).Row)
Set z = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(a, 1)
    If Not z.exists(a(i, 1)) Then
        z.Add a(i, 1), 1
    Else
        z.Item(a(i, 1)) = z.Item(a(i, 1)) + 1
    End If
Next i
For Each vKey In z.keys
    If z.Item(vKey) = 1 Then
        z.Remove (vKey)
    End If
Next vKey
If z.Count > 0 Then
    Application.ScreenUpdating = False
    [B1].Resize(z.Count, 2) = Application.Transpose(Array(z.keys, z.items))
    Application.ScreenUpdating = True
    MsgBox "işlem Tamam..!!"
End If

'*******************************************************
Set z = Nothing
Set s1 = Nothing
End Sub

 

[tiranorex]

Evren Hocam çok sağolasın, ellerine sağlık.

Saygılarımla..