Makro ile Mükerrer verileri benzersiz olarak bir sütuna yazdırmak

[Bwtunc]

Merhaba,

Private Sub CommandButton1_Click()
Call Makro4
Set s1 = Sheets("Sayfa1")
sonaa = s1.Range("A" & Rows.Count).End(3).Row
sonss = s1.Range("B" & Rows.Count).End(3).Row
On Error Resume Next
For i = 2 To sonaa
rr = WorksheetFunction.Match(s1.Cells(i, 2), s1.Range("A2:A" & sonss), 0) + 1
If Not (s1.Cells(i, 1)) = s1.Cells(rr, 2) Then
sat = s1.Range("D" & Rows.Count).End(3).Row + 1
s1.Range("D" & sat) = s1.Cells(i, 1)
End If
Next i
CommandButton7_Click
End Sub

Daha önce yine Excel.Web.Tr adresinde bulduğum kullanışlı bir dosyanın konu var yukarıda. Bu koda benzer mantıkla mükerrer verileri benzersiz olarak E sütununa yazdırmak istiyorum o bir türlü olmadı. Destek verebilecek arkadaşım var mıdır?

Teşekkürler.

 

[numan şamil]

Merhaba
Yanlış anlamadıysam
"A2:A" Sutunundaki mükerrerleri
"E2:E" Sutununa benzersiz şekilde yazar
Denermisiniz
Sub Numan()
Dim Son, Sat, x, y As Integer
Range("E2:E" & Rows.Count).ClearContents
Sat = 2
Son = Cells(Rows.Count, "A").End(xlUp).Row
Application.ScreenUpdating = False
For x = 2 To Son
If WorksheetFunction.CountIf(Range("A:A"), Cells(x, "A")) > 1 Then
Cells(Sat, "E") = Cells(x, "A")
Sat = Sat + 1
End If
Next x
For y = Son To 2 Step -1
If WorksheetFunction.CountIf(Range("E:E"), Cells(y, "E")) > 1 Then
Range("E:E").Rows.Delete
End If
Next y
Application.ScreenUpdating = True
End Sub

 

[Bwtunc]

Merhaba Öncelikle geri dönüş için teşekkür ederim. Ama kodda önce hata aldım. Hata sonrası kodun altına bir End Sub daha koydum ama olmadı . Sonra muhtemelen kod iki Sub ile başlayamaz diye düşünüp Private Sub bölümünü sildim. Bunu yaptıktan sonra hata durdu.

Private Sub CommandButton9_Click()
Sub Numan ()

Fakat Makroyu çalıştırdığımda hiçbirşey bulmuyor. Bunun nedenide

If WorksheetFunction.CountIf(Range("E:E"), Cells(y, "E")) > 1 Then
Range("E:E").Rows.Delete

Bu bölümde diye düşünüyorum çünkü siliyor. Kodu anlamaya çalıştığım için yorum yapıyorum lütfen yanlış anlaşılmasın. Çünkü makro kodlarını bilmiyorum kendimce bu şekilde bir bilgi daha edinmiş oluyorum.

 

[Korhan Ayhan]

Mükerrer verileriniz hangi sütunda?

 

[numan şamil]

Merhaba
Mükerrer verileriniz "A" sütununa ve "A2" hücresinden başlıyorsa benim verdiğim kodlar "A" sutunundaki kodlara bir şey yapmadan
"E" sütununda benzersiz(teke indirerek) sıralar
Muhtemelen çalışmama sebebi siz buton kullanmışsınız Sub numan() ile düğmeye atamak için bunu biliyorsunuz zannetmiştim.
Şimdi Sub numan() satırını silip
yerine Private Sub CommandButton9_Click() yazıp deneyebilirmisiniz