Esit degerlerin hepsini yan yana sırala

[hopeful]

Merhaba,
A ve B kolonlarında yer alan : No1 ve No2 değerleri birbirlerine eşittir.

Örnek olarak ;
11abc012 = 11def016

11def016 değeri ise başka satırlarda başka bir değerlere eşit :

11def016=10def034
11def016=11def001
11def016=11def003
...

Sonuçta

11abc012=11def016=11def014=11def013=10def034=11def001=11def003=11def014

Tüm eşit değerleri yan yana yazan bir makro oluşturmak mümkün müdür?
Yardımınızı rica ederim.

Dosya ve açıklama ektedir..

 

[Asri]

Bunlar nasıl bir birine eşit oluyor. Kuralı nedir?

11abc012 = 11def016
11def014= 11def013

 

[hopeful]

Haklisiniz eksik aciklama yapmisim.
Bunlari urun kodlari olarak dusunebilirsiniz.
Urunlerin kodlari farkli ancak, urunler birbirlerinin ayni.

Ya da ingilizce kelimeler olarak dusunelim. Ayni satirdaki kelimelerin anlamlari ayni.

Kodlari farkli olmasina ragmen birbirlerinin aynisi olan bu urunleri ya da yazilislari farkli ancak anlamlari ayni olan kelimeleri yan yana siralatmak amacim..

 

[Asri]

Haklisiniz eksik aciklama yapmisim.
Bunlari urun kodlari olarak dusunebilirsiniz.
Urunlerin kodlari farkli ancak, urunler birbirlerinin ayni.

Ya da ingilizce kelimeler olarak dusunelim. Ayni satirdaki kelimelerin anlamlari ayni.

Kodlari farkli olmasina ragmen birbirlerinin aynisi olan bu urunleri ya da yazilislari farkli ancak anlamlari ayni olan kelimeleri yan yana siralatmak amacim..

Örnek dosyanız bu dediğiniz şartları sağlamıyor.
Örnek dosyanızı gerçek olmasada bire bir şartları sağlayan örnek veriler ile güncelleyebilir misiniz.

Bu şekilde yardımcı olunamaz.

 

[hopeful]

Ornek dosyam bizzat calisma dosyasidir:

Baska bir ornekle aciklamaya calisayiim tekrar:

A1: Ali
B1: Veli
Ali ile Veli aynıyaştalar(yaslarinin kac oldugu onemli degil)

A2: Ahmet
B2: Mehmet
Ahmet ve Mehmet ayni yastalar
...
A100: Hakan
B100: Serkan
Hakan ve Serkan da kendi kendi aralarinda ayni yastalar..

Diyelim ki
A101: Kaan
B101: Ali
Kaan ve Ali ayni yastalar.. Ama daha once Ali ile veli de ayni yastaydi.
O halde Ali, Veli, Kaan ayni yastalar...

Dosyada isinler yok kodlar var.
Ayni olan urunlere ait barkod numaralari hangileri??

 

[Asri]

Ornek dosyam bizzat calisma dosyasidir:

Kolay gelsin o zaman.

 

[esalci]

Örnek dosyayı dosya.tc, dosya.co gibi bir siteye yükleyebilirmisin?

 

[askm]

Biraz uzun yoldan oldu ama olan bu şekilde.İnşallah doğrudur.

Sub askm()
Dim SonSat As Long
SonSat = Range("A" & Rows.Count).End(xlUp).Row


For i = 2 To SonSat
Application.ScreenUpdating = False
a = 1
Range("Z1:AH10000").ClearContents
    For k = 2 To SonSat
        Aranan = Cells(i, 1)
        If Aranan = Cells(k, 1) Then
            Cells(a, "Z") = k
            Cells(a, "AA") = Cells(k, 1)
            a = a + 1
            Cells(a, "AA") = Cells(k, 2)
            a = a + 1
        End If
    Next k
    For k = 2 To SonSat
        If Aranan = Cells(k, 2) Then
            Cells(a, "Z") = k
            Cells(a, "AA") = Cells(k, 1)
            a = a + 1
            Cells(a, "AA") = Cells(k, 2)
            a = a + 1
        End If
    Next k
    For k = 2 To SonSat
        Aranan = Cells(i, 2)
        If Aranan = Cells(k, 1) Then
            Cells(a, "Z") = k
            Cells(a, "AA") = Cells(k, 1)
            a = a + 1
            Cells(a, "AA") = Cells(k, 2)
            a = a + 1
        End If
    Next k
     For k = 2 To SonSat
        If Aranan = Cells(k, 2) Then
            Cells(a, "Z") = k
            Cells(a, "AA") = Cells(k, 1)
            a = a + 1
            Cells(a, "AA") = Cells(k, 2)
            a = a + 1
        End If
    Next k
    sayi = WorksheetFunction.CountIf(Range("AA1:AA1000"), "<>")
    If sayi > 2 Then
        Range("AA1:AA1000").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range( _
        "AD1"), Unique:=True
        str1 = 0
        SonSat2 = Range("AD" & Rows.Count).End(xlUp).Row
        For x = 1 To SonSat2
            Aranan = Cells(x, "AD")
            str1 = str1 + 1
            Cells(str1, "AF") = Aranan
            For y = 2 To SonSat
                If Aranan = Cells(y, 1) Then
                    str1 = str1 + 1
                    Cells(str1, "AF") = Cells(y, 2)
                End If
            Next y
            For y = 2 To SonSat
                If Aranan = Cells(y, 2) Then
                    str1 = str1 + 1
                    Cells(str1, "AF") = Cells(y, 1)
                End If
            Next y
        Next x
    End If
     Range("AF1:AF1000").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range( _
        "AH1"), Unique:=True
    SonSat3 = Range("AH" & Rows.Count).End(xlUp).Row

    For tl = 1 To SonSat3
        deger = deger & "=" & Cells(tl, "AH")
    Next tl
    Cells(i, "C") = Mid(deger, 2, Len(deger) - 1)
    Range("Z1:AH10000").ClearContents
  Application.ScreenUpdating = True
  
Next i
MsgBox "İşlem tamamlandı..." & Chr(10) & Chr(10) & "İyi çalışmalar...", vbInformation, "ASKM"
End Sub