Benzer rakamlı hücreler

[leonidas]

Selam Arkadaşlar
Bir konuda yardımınızı rica ederim. 10 haneden oluşan sayıların oluşturduğu bir listem var bunlar içinden ilk 6 hanesinin aynı olduğu numaraların satırlarını 2. sayfaya kopyalayan bir sisteme ihtiyacım var. Bana yol gösterebilirseniz sevinirim.

 

[Orion1]

Aktif sayfanın a sütununu mükerrer kayıtları sayfa2ye a sütununa atar.

Sub mukerrer()
Dim z As Object, sat As Long, i As Long, a As Collection
Set z = CreateObject("Scripting.Dictionary")
Set a = New Collection
For i = 1 To Cells(65536, "A").End(xlUp).Row
    deg = Left(Cells(i, "A").Value, 6)
    If Not z.exists(deg) Then
        z.Add deg, 1
        Else
        z.Item(deg) = z.Item(deg) + 1
    End If
Next i

For Each vKey In z.keys
    If z.Item(vKey) = 1 Then
        z.Remove (vKey)
    End If
Next vKey
[Sayfa2!A1].Resize(z.Count, 1) = Application.Transpose(Array(z.keys, z.items))
MsgBox "İşlem tamam"
End Sub

 

[leonidas]

Çok Teşekkür ederim.
YAlnız bir şey daha rica edebilirmiyim aynı olduğunu tesbit ettiği satırları 2. sayfaya kopyalaması mümkünmü?

 

[Necdet]

Zaten öyle yapıyor. Denemeden mi yanıt verdiniz?

 

[Orion1]

İLk 6 hanesini sayfa2ye atıyor.