Sütunları satırlara çevirme

[batumania]

Herkese merhaba Kadir geceniz mübarek olsun.
1500 satırlık müşteri ve ürünler olan bir exel dosyam var. Ben bunları müşteri bazında satırlara dönüştürüp ürün kodlarına ürün linklerini bağlantı olarak eklemek istiyorum. Bunu nasıl yapabilirim?
Mevcut dosyam

Olmasını istediğim hali

 

[Korhan Ayhan]

Örnek dosya paylaşabilir misiniz?

 

[batumania]

Örnek dosya paylaşabilir misiniz?

Orjinal dosya değil ama örnek dosya linki

Dosya.xlsx dosyasını indir - download

Dosya.xlsx dosyasını indir, download. Dosya.tc .Dosya Upload. Dosya Paylaş. Dosya Yükle

s6.dosya.tc

 

[YUSUF44]

Aşağıdaki makroyu bir modüle kopyalayıp deneyiniz:

Sub aktar()
Set s1 = Sheets("Olan")
Set s2 = Sheets("Sayfa2")
eskisat = WorksheetFunction.Max(2, s2.Cells(Rows.Count, "A").End(3).Row)
eskisut = WorksheetFunction.Max(3, s2.Cells(1, Columns.Count).End(xlToLeft).Column)
s2.Range(Cells(1, "C"), Cells(eskisat, eskisut)).ClearContents
son = s1.Cells(Rows.Count, "A").End(3).Row
Application.ScreenUpdating = False
    yeni = s2.Cells(Rows.Count, "A").End(3).Row + 1
    s2.[C1] = "Ürün Kodu 1"
    s2.[D1] = "Ürün Resmi Linki 1"
    For musteri = 2 To son
        If WorksheetFunction.CountIf(s2.Range("A1:A" & yeni), s1.Cells(musteri, "A")) = 0 Then
            s2.Cells(yeni, "A") = s1.Cells(musteri, "A")
            s2.Cells(yeni, "B") = s1.Cells(musteri, "B")
            s2.Cells(yeni, "C") = s1.Cells(musteri, "C")
            s2.Cells(yeni, "D") = s1.Cells(musteri, "E")
        Else
            sat = WorksheetFunction.Match(s1.Cells(musteri, "A"), s2.Range("A1:A" & yeni), 0)
            sut = WorksheetFunction.Max(3, s2.Cells(sat, Columns.Count).End(xlToLeft).Column + 1)
            s2.Cells(sat, sut) = s1.Cells(musteri, "C")
            s2.Cells(sat, sut + 1) = s1.Cells(musteri, "E")
            If s2.Cells(1, sut) = "" Then
                s2.Cells(1, sut) = "Ürün Kodu " & (sut - 1) / 2
                s2.Cells(1, sut + 1) = "Ürün Resmi Linki " & (sut - 1) / 2
            End If
        End If
    Next
Application.ScreenUpdating = True
s2.Activate
MsgBox "İşlem tamamlandı.", vbInformation
End Sub

 

[Ziynettin]

Alternatif kod.

Sub test()
Dim Ws1 As Worksheet, Ws2 As Worksheet
Set Ws1 = Sheets("Olan")
Set Ws2 = Sheets("Sayfa2")
Set dc = CreateObject("scripting.dictionary")
Set dc1 = CreateObject("scripting.dictionary")
    son = Ws1.Cells(Rows.Count, "A").End(3).Row
    a = Ws1.Range("A1:E" & son).Value
    sutun = Array(3, 5)
    
        For i = 2 To UBound(a)
            krt = a(i, 1) & "|" & a(i, 2)
            For j = 0 To UBound(sutun)
                dc(krt) = dc(krt) & "#" & a(i, sutun(j))
                dc1(krt) = dc1(krt) + 1
            Next j
        Next i
        
    sut = Application.Max(dc1.items) + 2
    ReDim b(1 To dc.Count, 1 To sut)
    
    For Each v In dc.keys
        say = say + 1
        b(say, 1) = Split(v, "|")(0)
        b(say, 2) = Split(v, "|")(1)
        m = Split(dc(v), "#")
        For j = 1 To UBound(m)
            b(say, 2 + j) = m(j)
        Next j
    Next v

    Ws2.[A2] = "wwww"
    s_sat = Ws2.Cells(Rows.Count, 1).End(3).Row
    s_sut = Ws2.Cells.Find("*", , , , xlByColumns, xlPrevious).Column
    Ws2.Range("A2", Ws2.Cells(s_sat, s_sut)).ClearContents
    Ws2.[A2].Resize(dc.Count, sut) = b
MsgBox "İşlem tamam...", vbInformation
End Sub