Kod ile Remove Duplicates

[tamer42]

Merhaba,
Ekli dosya A sütununda karışık kodlar yazılı, bir koddan bir çok defa yazılmış olabilir. her koddan bir defa alınacak

Özetle A sütununda RemoveDuplicates işlemini yaptırmak ve çıkan tek sonuçları aralarında , işareti ile yan yana yazdırmak istiyorum (C1 hücresindeki gibi...)

Teşekkürler,

iyi çalışmalar.

 

[Haluk]

Sub Test()
    'Haluk
    '09/10/2018
    
    Dim myFile As String
    Dim daoDBEngine As Object
    Dim DB As Object
    Dim RS As Object
    Dim RetVal As String
    Dim i As Integer
    
    myFile = ThisWorkbook.FullName
    
    On Error Resume Next
        Set daoDBEngine = CreateObject("DAO.DBEngine")
        Set daoDBEngine = CreateObject("DAO.DBEngine.36")
        Set daoDBEngine = CreateObject("DAO.DBEngine.120")
    On Error GoTo 0
    
    Set DB = daoDBEngine.OpenDatabase(myFile, False, False, "Excel 8.0; HDR=No; IMEX=1;")
    Set RS = DB.OpenRecordset("Select distinct F1 from [Sheet2$]")
    
    RS.MoveFirst
    For i = 1 To RS.RecordCount
        RetVal = RetVal & RS.Fields(0) & ","
        RS.MoveNext
    Next
    Range("C1") = Left(RetVal, Len(RetVal) - 1)
    
    RS.Close
    DB.Close
    Set RS = Nothing
    Set DB = Nothing
    Set daoDBEngine = Nothing
End Sub

.

 

[tamer42]

Teşekkürler,
Açık dosya üzerinden nasıl yapabiliriz?

iyi çalışmalar.

 

[Haluk]

"Açık dosya üzerinden...." derken ?

Zaten 1 tane dosya var, kodu da o dosyaya yazıyorsunuz.....

Siz kapalı bir dosyadan verileri alıp, açık olan başka bir dosyaya mı yazmak istiyorsunuz?

.

 

[tamer42]

Sn Haluk merhaba,
Veriler açık olan dosyada yazılı, her hangibir yerden veri alınmayacak,

yalnız buradaki veriler silinmeden işlemi başka bir hücrede yapacak....

Teşekkürler,

 

[Haluk]

Tamer bey;

Kod zaten A sütunundaki verileri alıp, ayıkladıktan sonra sizin isteğiniz doğrultusunda C1 hücresine virgülle birleştirerek getiriyor.

Silinen herhangi bir şey yok.... Ben mi anlamıyorum sizi acaba ?

.

 

[tamer42]

Tamer bey;

Kod zaten A sütunundaki verileri alıp, ayıkladıktan sonra sizin isteğiniz doğrultusunda C1 hücresine virgülle birleştirerek getiriyor.

Silinen herhangi bir şey yok.... Ben mi anlamıyorum sizi acaba ?

.

Sn Haluk, A sütunuda aynı veriler double, Örnek: B1 verisinden 4 adet, B3 verisinden 6 adet, var; hepsinden 1' er adet alacak

Teşekkürler,

 

[Haluk]

Tamer Bey;

Siz kodu ya hiç denemediniz, ya da kodu çalıştırmayı bilmiyorsunuz.

Son ihtimal de; kötü bir şaka yapıyorsunuz........

Kod zaten dediklerinizi yapıyor.

.

 

[tamer42]

Sn Haluk kusura bakmayın
DAO görünce kapalı bir dosyadan veri alınacak gibi düşündüm.

Çok teşekkürler,

 

[Ömer BARAN]

Merhaba, alternatif olsun.
.

Sub tekrarsiz_virgullu_birlestir()
For sat = 1 To Cells(Rows.Count, 1).End(3).Row
    If WorksheetFunction.CountIf(Range("A1" & ":A" & sat), Cells(sat, 1)) = 1 Then _
        veri = veri & ", " & Cells(sat, 1)
Next: [C1] = Mid(veri, 3, Len(veri))
End Sub

 

[Haluk]

Sub Test2()
    ' Haluk - 09/10/2018
    Dim uniqueList As New Collection, strItem As Variant
    Dim myList() As Variant
    Dim NoA As Long, i As Long, RetVal As String
    
    NoA = Range("A" & Rows.Count).End(xlUp).Row
    myList() = Range("A1:A" & NoA)
    
    On Error Resume Next
    For Each strItem In myList
       uniqueList.Add strItem, strItem
    Next
    
    For i = 1 To uniqueList.Count
       RetVal = RetVal & uniqueList(i) & ","
    Next
    
    Range("C1") = Left(RetVal, Len(RetVal) - 1)
End Sub

.

 

[Korhan Ayhan]

Bende alternatif kod hazırladım.

50.000 satırlık benzersiz listede testler yapabilirsiniz.

 

[tamer42]

Bende alternatif kod hazırladım.

50.000 satırlık benzersiz listede testler yapabilirsiniz.

Sn Korhan RAR' lı dosyayı açamıyorum, tekrar yükleyebilir misin,

Teşekkürler

 

[Korhan Ayhan]

Ektedir..

 

[tamer42]

Sub Test2()
    ' Haluk - 09/10/2018
    Dim uniqueList As New Collection, strItem As Variant
    Dim myList() As Variant
    Dim NoA As Long, i As Long, RetVal As String
   
    NoA = Range("A" & Rows.Count).End(xlUp).Row
    myList() = Range("A1:A" & NoA)
   
    On Error Resume Next
    For Each strItem In myList
       uniqueList.Add strItem, strItem
    Next
   
    For i = 1 To uniqueList.Count
       RetVal = RetVal & uniqueList(i) & ","
    Next
   
    Range("C1") = Left(RetVal, Len(RetVal) - 1)
End Sub

.

Sn Haluk burada verdiğiniz kodu fonksiyon haline getirdim, Sütun ve Son Satır bilgilerini değişken girerek...........

Sizin düşünceniz nedir?
Teşekkürler,

Function Tekrarsiz(xlColumn As String, NoA As Long)
   
    Dim uniqueList As New Collection, strItem As Variant
    Dim myList() As Variant
    Dim xlCol As String, i As Long, RetVal As String
    
  
  xlCol = xlColumn & "2:" & xlColumn
  
    myList() = Sheets(1).Range(xlCol & NoA)
    
    On Error Resume Next
    For Each strItem In myList
       uniqueList.Add strItem, strItem
    Next
    
    For i = 1 To uniqueList.Count
       RetVal = RetVal & uniqueList(i) & ","
    Next
    
    Tekrarsiz = Left(RetVal, Len(RetVal) - 1)
    
    
End Function

 

[Haluk]

Şöyle olabilir ....

Function Tekrarsiz(myRange As Range)
    Dim uniqueList As New Collection, strItem As Variant
    Dim i As Long, RetVal As String

    On Error Resume Next
    For Each strItem In myRange
       uniqueList.Add strItem, strItem
    Next
 
    For i = 1 To uniqueList.Count
       RetVal = RetVal & uniqueList(i) & ","
    Next
 
    Tekrarsiz = Left(RetVal, Len(RetVal) - 1)
End Function

Kullanımı ise;

=Tekrarsiz(A1:A24)

Dosyası da ekte verilmiştir.


.

 

[tamer42]

Şöyle olabilir ....

Function Tekrarsiz(myRange As Range)
    Dim uniqueList As New Collection, strItem As Variant
    Dim i As Long, RetVal As String

    On Error Resume Next
    For Each strItem In myRange
       uniqueList.Add strItem, strItem
    Next

    For i = 1 To uniqueList.Count
       RetVal = RetVal & uniqueList(i) & ","
    Next

    Tekrarsiz = Left(RetVal, Len(RetVal) - 1)
End Function

Kullanımı ise;

=Tekrarsiz(A1:A24)

Dosyası da ekte verilmiştir.


.

Çok teşekkür ederim Sn Haluk,
ufkumuzu açıyorsunuz ....

 

[tamer42]

Çok teşekkür ederim Sn Haluk,
ufkumuzu açıyorsunuz ....

Şöyle olabilir ....

Function Tekrarsiz(myRange As Range)
    Dim uniqueList As New Collection, strItem As Variant
    Dim i As Long, RetVal As String

    On Error Resume Next
    For Each strItem In myRange
       uniqueList.Add strItem, strItem
    Next

    For i = 1 To uniqueList.Count
       RetVal = RetVal & uniqueList(i) & ","
    Next

    Tekrarsiz = Left(RetVal, Len(RetVal) - 1)
End Function

.

Sn Haluk iyi akşamlar,
bu başlıkta sizin yine desteğinize ihtiyacım var, bildiğiniz üzere yukarıda verdiğiniz Fonksiyon "Tekrarsiz(myRange As Range)"
hücreleri karşılaştırarak benzersiz olanları alıyor,
hücre içerisinde soldan 1. karakterleri

 Left (strItem, 1)

aynı yöntemde nasıl bulabilirsiniz, bu dosya özelinde sonuç A ve B olacak...

Teşekkürler,

 

[Haluk]

Kırmızı ile işaretlenen ilaveyi yapın ....

Function Tekrarsiz(myRange As Range)
    Dim uniqueList As New Collection, strItem As Variant
    Dim i As Long, RetVal As String

    On Error Resume Next
    For Each strItem In myRange
        strItem = Left(strItem, 1)
        uniqueList.Add strItem, strItem
    Next
  
    For i = 1 To uniqueList.Count
       RetVal = RetVal & uniqueList(i) & ","
    Next
  
    Tekrarsiz = Left(RetVal, Len(RetVal) - 1)
End Function

 

[tamer42]

Çok teşekkürler....