Transpone question

[Belleke]

I have troubles to find the right code.
See example.

 

[shrivallabha]

There's no desired result in result sheet in your attachment.

But you probably want:
1. List unique names of fruits in first column.
2. Paste dates horizontally (will there be date duplicates?)

 

[Luke M]

Try this

Sub NewCode()
    Dim wsDest As Worksheet
    Dim tb As ListObject
    Dim c As Range
    Dim rngList As Range
    Dim lastRow As Long
    Dim lastCol As Long
   
    Set wsDest = Worksheets("Result")
    Set tb = Worksheets("List").ListObjects(1)
   
    Application.ScreenUpdating = False
   
    tb.ListColumns("Fruit").Range.Copy
    wsDest.Range("A1").PasteSpecial xlPasteValues
    'Create unique list
    wsDest.Range("A:A").RemoveDuplicates Columns:=1, Header:=xlYes
   
    With wsDest
        lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
        If lastRow = 1 Then
            MsgBox "No data transferred"
            Exit Sub
        End If
        Set rngList = .Range("A2:A" & lastRow)
       
        'Loop through our list of fruit
        For Each c In rngList
            tb.Range.AutoFilter field:=tb.ListColumns("Fruit").Index, Criteria1:=c.Value
            tb.ListColumns("Date").DataBodyRange.SpecialCells(xlCellTypeVisible).Copy
            c.Offset(0, 1).PasteSpecial xlPasteValuesAndNumberFormats, Transpose:=True
           
            'sort dates
            .Sort.SortFields.Clear
            .Sort.SortFields.Add Key:=.Range(c.Offset(0, 1), c.End(xlToRight)), _
                SortOn:=xlSortOnValues, Order:=xlAscending
            .Sort.SetRange .Range(c.Offset(0, 1), c.End(xlToRight))
            .Sort.Orientation = xlSortRows
            .Sort.Apply
        Next c
    End With
   
    'Cleanup
    tb.Range.AutoFilter
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub

 

[Belleke]

Shrivallabha and Luke, thank you for looking into my problem.
@Luke, works like a charm.
Problem solved, have a nice day.