mükerrer kayıt makrosu

[imyourfate]

arkadaşlar iyi akşamlar

aşağıdaki makro ile ekli dosyadada görebileceğiniz gibi S202 hücresinden aşagıya sonu önemli değil s600 e kadar olabilir mükerrer kayıtlar mevcut ben bunları sadece 1 kere kullanıp B sütünunda b6 dan başlayacak şekilde listelemek istiyorum kullanmaya çalıştığım makro budur ekli dosya mevcut

Hayırlı akşamlar Saygılar

Sub Benzersizlertopla()
Dim Dizi() As Variant
Dim Alan1 As Range, Alan2 As Range, BirlesenAlan As Range
Set Alan1 = Range("S202")
Set BirlesenAlan = Range("B6")
AlanTopla = Alan1.Cells.Count
ReDim Dizi(AlanTopla, 2)
For Each Hucre In Alan1
i = i + 1
Dizi(i, 1) = Hucre.Value
Next Hucre
Sirala = False
While Not Sirala
Sirala = True
For i = 1 To UBound(Dizi) - 1
If Dizi(i, 1) > Dizi(i + 1, 1) Then
stor1 = Dizi(i, 1)
Dizi(i, 1) = Dizi(i + 1, 1)
Dizi(i + 1, 1) = stor1
Sirala = False
Exit For
End If
Next i
Wend
Dizi(1, 2) = False
For i = 1 To UBound(Dizi) - 1
If Dizi(i, 1) = Dizi(i + 1, 1) Then
Dizi(i + 1, 2) = True
Else
Dizi(i + 1, 2) = False
End If
Next i
j = 0
For i = 1 To UBound(Dizi)
If Not Dizi(i, 2) Then
BirlesenAlan.Offset(j, 0).Value = Dizi(i, 1)
j = j + 1
End If
Next i
End Sub

 

[Levent Menteşoğlu]

Aşağıdaki kodu deneyin.

Sub Benzersizlerlistele()
For a = 202 To [s65536].End(3).Row
If WorksheetFunction.CountIf(Range("s202:s" & a), Cells(a, "s")) = 1 Then
c = c + 1
Cells(c + 5, "b") = Cells(a, "s")
End If
Next
End Sub

 

[imyourfate]

levent Hocam mükemmel bir çalışma ellerinize sağlık teşekkürlerimi sunarım