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,

Katılım
13 Ekim 2022
Mesajlar
40
Excel Vers. ve Dili
2016
Altın Üyelik Bitiş Tarihi
31-10-2023
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

    
 
Son düzenleme:

Muzaffer Ali

Destek Ekibi
Destek Ekibi
Katılım
5 Haziran 2006
Mesajlar
6,167
Excel Vers. ve Dili
2019 Türkçe
Merhaba.

Kod:
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
 

ÖmerFaruk

Destek Ekibi
Destek Ekibi
Katılım
22 Ekim 2017
Mesajlar
4,779
Excel Vers. ve Dili
Microsoft 365 Tr-64
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.
C++:
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
 

Ömer

Moderatör
Yönetici
Katılım
18 Ağustos 2007
Mesajlar
22,184
Excel Vers. ve Dili
Microsoft 365 Tr
Ofis 2016 Tr
Merhaba,

Alternatif.
Kod:
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
 
Katılım
13 Ekim 2022
Mesajlar
40
Excel Vers. ve Dili
2016
Altın Üyelik Bitiş Tarihi
31-10-2023
çok teşekkür ederim @Ömer bey
 
Üst