Soru Dikey tablodan yatay veri geliştirme

[moodhub]

Merhaba,
ekteki tabloda "ulaşılmak istenilen veri bölümü" diye belirttiğim verilerin binlerce satır uzunluğunda oluşturmam gerekiyor.
Özetle; Aynı ürünün ilgili ürünlerini (diğer alternatif renklerini) belirlememiz gerekiyor.
Yardımcı olursanız çok sevinirim, aksi taktirde hafta sonu manuel olarak bu işlemi hatasız olarak yapmam gerekecek.
Çok teşekkürler,
Hasan

ULAŞILMAK İSTENEN VERİ BÖLÜMÜ       Ürün Kodu Ürün Adı Renk ilgili ürün 1 ilgili ürün 2 ilgili ürün 3 ilgili ürün 4 22634 TENTEN | VAZO SARI 22635 22636 22637 22638 22635 TENTEN | VAZO MAVİ 22634 22636 22637 22638 22636 TENTEN | VAZO KIRMIZ 22634 22635 22637 22638 22637 TENTEN | VAZO TURUNCU 22634 22635 22636 22638 22638 TENTEN | VAZO MOR 22634 22635 22636 22637 22639 TENTEN | TABLO SİYAH         22640 TENTEN | BİBLO BEYAZ         22641 TENTEN | TABAK KAHVE 22642       22642 TENTEN | TABAK BEJ 22641         …

 

[veyselemre]

Sub test()
    Dim veri, i&, ky$, sut%, bl, ii%, son%
    son = Cells(Rows.Count, 1).End(3).Row
    veri = Range("A2:B" & son).Value
    Range("D2:N" & son).ClearContents
    With CreateObject("Scripting.Dictionary")
        For i = 1 To UBound(veri)
            ky = veri(i, 2)
            .Item(ky) = .Item(ky) & "," & veri(i, 1)
        Next i
        For i = 2 To son
            ky = Cells(i, 2).Value
            If .exists(ky) Then
                bl = Split(Mid(.Item(ky), 2), ",")
                If UBound(bl) > 0 Then
                    sut = 4
                    For ii = 0 To UBound(bl)
                        If Trim(bl(ii)) <> Trim(Cells(i, 1).Value) Then
                            Cells(i, sut).Value = bl(ii)
                            sut = sut + 1
                        End If
                    Next ii
                End If
            End If
        Next i
    End With

End Sub

 

[moodhub]

Veysel Bey çok teşekkürler, minnettarım. Aklınıza, elinize kolunuza sağlık.
Kusursuz çalıştı.
Ulaşmak istediğim nihai durum ise aşağıdaki gibi.
Yani esasında sadece iki sütunlu bir tabloya ulaşmam gerekiyor. Tüm ilişkili ürünler aşağıya doğru uzayacak şekilde.
Bu tabloyu direkt olarak nihai haline dönüştürmek mümkün mü?
Yardımcı olursanız çok sevinirim.
Hasan

MEVCUT TABLO ULAŞILMAK İSTENEN NİHAİ TABLO       Ürün Kodu Ürün Adı Renk Ürün Kodu ilgili ürün 22634 TENTEN | VAZO SARI 22634 22635 22635 TENTEN | VAZO MAVİ 22634 22636 22636 TENTEN | VAZO KIRMIZ 22634 22637 22637 TENTEN | VAZO TURUNCU 22634 22638 22638 TENTEN | VAZO MOR 22635 22634 22639 TENTEN | TABLO SİYAH 22635 22636 22640 TENTEN | BİBLO BEYAZ 22635 22637 22641 TENTEN | TABAK KAHVE 22635 22638 22642 TENTEN | TABAK BEJ 22636 22634       22636 22635       22636 22637       22636 22638       22637 22634       22637 22635       22637 22636       22637 22638       22638 22634       22638 22635       22638 22636       22638 22637       22639         22640         22641 22642       22642 22641

 

[veyselemre]

Sub test()
    Dim veri, i&, ky$, sat%, bl, ii%, iii%, son%, itms
    son = Cells(Rows.Count, 1).End(3).Row
    veri = Range("A2:B" & son).Value
    Range("D2:E" & son).ClearContents
    With CreateObject("Scripting.Dictionary")
        For i = 1 To UBound(veri)
            ky = veri(i, 2)
            .Item(ky) = .Item(ky) & "," & veri(i, 1)
        Next i
        sat = 2
        itms = .items
        For i = 0 To UBound(itms)
            bl = Split(Mid(itms(i), 2), ",")
            If UBound(bl) > 0 Then
                For ii = 0 To UBound(bl)
                    For iii = 0 To UBound(bl)
                        If ii <> iii Then
                            Cells(sat, 4).Value = bl(ii)
                            Cells(sat, 5).Value = bl(iii)
                            sat = sat + 1
                        End If
                    Next iii
                Next ii
            Else
                Cells(sat, 4).Value = bl(0)
                sat = sat + 1
            End If
        Next i
    End With

End Sub

 

[moodhub]

Veysel Bey çok teşekkür ederim. Kusursuz çalışıyor. Minnettarım.
Saygılarımla,