A değerini B deki karşılığına bakarak D de sıralama B de farklı bulduğu değerleride yan yana, E , G... de göstermek,

[ayhanycelik]

A değerini B deki karşılığına bakarak D de sıralama B de farklı bulduğu değerleride yan yana, E , G... de gösterme

15160200TR025614	2015-285		15160200TR025614	2015-285	2015-522
15160200TR025614	2015-285		15160200TR018388	2015-256
15160200TR026001	2015-284		15160200TR017582	2015-252
15160200TR025614	2015-522		15160200TR026001	2015-284
15160200TR018388	2015-256
15160200TR018388	2015-256
15160200TR017582	2015-252
15160200TR017582	2015-252

 

[Muzaffer Ali]

Merhaba.

Sub test()
    Dim Bak As Long
    Dim Bul As Range
    Dim Say As Long
    Dim SayKolon As Long
    For Bak = 1 To Cells(Rows.Count, "A").End(xlUp).Row
        Set Bul = Range("D:D").Find(what:=Cells(Bak, "A"), lookat:=xlWhole)
        
        If Bul Is Nothing Then
            Say = Cells(Rows.Count, "D").End(xlUp).Row + 1
            If Range("D1") = "" Then Say = 1
            Cells(Say, "D") = Cells(Bak, "A")
            Cells(Say, "E") = Cells(Bak, "B")
        Else
            SayKolon = Cells(Bul.Row, Columns.Count).End(xlToLeft).Column
            If Range("D" & Bul.Row & ":" & Cells(Bul.Row, SayKolon).Address).Find(what:=Cells(Bak, "B"), lookat:=xlWhole) Is Nothing Then
                Cells(Bul.Row, SayKolon + 1) = Cells(Bak, "B")
            End If
        End If
    Next
    MsgBox "Tamamlandı."
End Sub

 

[ayhanycelik]

@Muzaffer Ali bey çok ama çok teşekkür ederim

 

[Muzaffer Ali]

Rica ederim. Kolay gelsin.

 

[ÖmerFaruk]

Ben uğraşıtken cevap gelmiş. Yine de alternatif olsun diye paylaşıyorum.
Belki verilerinizin çok olması durumunda hız açısından faydalı olur.

Gerekli açıklamaları KOD içinde belirttim.

Sub BenzersizListee()
    ' Mevcut liste A2 hücresinden başlayıp A:B sütununda listelenmiştir.
    ' Sonuç Listesi D2 hücresinden itibaren alta ve sağa doğruyazılacak
    ' Mevcut listenin sırasız olması durumu için sonuç liste önce A sonra B olmak üzere artan sırada sıralanmıştır
    ' C sütununun boş olması önemlidir
    ' D2 hücresinden itibaren alt ve sağ tarafta kullanılan bir veriniz olmamalıdır. Zira orayı her seferinde siliyorum
   
    Dim Dizi, Dict As Object, DictNew As Object, arrList As Object, Liste(), temp As Variant
    Dim i As Integer, Say As Integer, kolon As Integer
   
    'Mevcut A2-Bxx aralağını diziye alıyoruz
    Dizi = Range("A2:B" & Range("A" & Rows.Count).End(3).Row).Value
    Range("D2").CurrentRegion.ClearContents
   
    'Yeni objeleri setliyoruz
    Set arrList = CreateObject("System.Collections.ArrayList")
    Set Dict = CreateObject("Scripting.Dictionary")
    Set DictNew = CreateObject("Scripting.Dictionary")
   
    'Diziyi tekrarsız olacak şekilde dictionary içine alıyoruz
    For i = 1 To UBound(Dizi)
        If Not Dict.Exists(Dizi(i, 1) & "-xx-" & Dizi(i, 2)) Then
            Dict.Add Dizi(i, 1) & "-xx-" & Dizi(i, 2), i
        End If
    Next i
   
    'Tekrarsız dictionary objesini sıralamak için kolleksiyona alıyor ve sıralıyoruz
    For Each temp In Dict
        arrList.Add temp
    Next temp
    arrList.Sort
    'Sıralı ve Tekrarsız veriyi yeniden dictionary içine alıyoruz. Not: Yapılmaya da bilirdi.
    For Each temp In arrList
        DictNew.Add temp, Dict(temp)
    Next temp
   
    ReDim Liste(1 To Dict.Count, 1 To 1)
   
    'Sıralanmış durumdaki yeni dictionary içeriğini sayfaya aktarmak üzere listeye alıyoruz
    For i = 1 To DictNew.Count
        Bak = Split(DictNew.keys()(i - 1), "-xx-")
        If temp <> Bak(0) Then
            Say = Say + 1
            kolon = 1
            temp = Bak(0)
        End If
        kolon = kolon + 1
        If UBound(Liste, 2) < kolon Then ReDim Preserve Liste(1 To DictNew.Count, 1 To kolon)
        Liste(Say, 1) = Bak(0)
        Liste(Say, kolon) = Bak(1)

    Next i
    Range("D2").Resize(Say, UBound(Liste, 2)) = Liste
   
    Set Dict = Nothing: Set DictNew = Nothing: Set arrList = Nothing: Erase Dizi: Erase Liste
End Sub

 

[ayhanycelik]

çok teşekkür ederim @ÖmerFaruk bey

 

[Ömer]

Merhaba,

Alternatif.

Sub liste()

    Dim dizi, alan, d As Object, i As Long, s As Long

    Set d = CreateObject("Scripting.Dictionary")
   
    Application.ScreenUpdating = False
    Range("D1").CurrentRegion.ClearContents
   
    alan = Range("A1").CurrentRegion.Value
    ReDim dizi(1 To UBound(alan, 1), 1 To 2)
   
    For i = LBound(alan, 1) To UBound(alan, 1)
        If Not d.Exists(alan(i, 1)) Then
            s = s + 1
            d.Add alan(i, 1), s
            dizi(s, 1) = alan(i, 1)
            dizi(s, 2) = alan(i, 2)
        Else
            If dizi(d.Item(alan(i, 1)), 2) = Replace(dizi(d.Item(alan(i, 1)), 2), alan(i, 2), "") Then
                dizi(d.Item(alan(i, 1)), 2) = dizi(d.Item(alan(i, 1)), 2) & "|" & alan(i, 2)
            End If
        End If
    Next i

    Range("D1").Resize(s, 2) = dizi
    On Error Resume Next
    [E:E].TextToColumns Destination:=Range("E1"), DataType:= _
        xlDelimited, TextQualifier:=xlDoubleQuote, Other:=True, OtherChar:="|"
    Range("D1").CurrentRegion.Columns.AutoFit
   
    MsgBox "İşlem bitti.", vbInformation

End Sub

 

[ayhanycelik]

çok teşekkür ederim @Ömer bey