Transpose formül veya macro ile yapmak

[search77]

Merhaba Sevgili Arkadaşlar,

Ekli dosyamda açıklamalarım mevcut, formül veya macro için yardımcı olabilecek arkadaşlara şimdiden çok teşekkür ederi.

Saygı ve Sevgilerimle.

 

[Ömer]

Merhaba,

Formülle de yapılabilir fakat dizi formülleri kullanılacağı için büyük datalarda dosyada kasılma olabilir. Bu yüzden makro ile yapmanızı tavsiye ederim.

Module kopyalarak çalıştırınız.

Sub Listele()
 
    Dim c As Range, ilkadres As Variant, sut As Integer, i As Long
 
    [A:A].AdvancedFilter Action:=xlFilterCopy, CopyToRange:=[[COLOR=blue]E1[/COLOR]], Unique:=True
 
    Range("F2", Cells(Rows.Count, Columns.Count)).ClearContents
 
    For i = 2 To Cells(Rows.Count, "E").End(xlUp).Row
        sut = [[COLOR=blue]E1[/COLOR]].Column + 1
        With Range("A:A")
            Set c = .Find(Cells(i, "E"), LookIn:=xlValues, LookAt:=xlWhole)
            If Not c Is Nothing Then
                ilkadres = c.Address
                Do
                    Cells(i, sut) = Cells(c.Row, "B")
                    sut = sut + 1
                    Set c = .FindNext(c)
                Loop While Not c Is Nothing And c.Address <> ilkadres
            End If
        End With
    Next i
 
End Sub

.

 

[search77]

Ömer bey,

Süper süper süper, mükemmel olmuş, elinize sağlık,

Teşekkürler.

Saygı ve sevgilerimle.