Pasting data horizontally [closed]

Question

I need to paste the data from my pivot like below. Transpose pasting is not working.

Is there any other option or macro?

Answer 1

Transform Data

Option Explicit

Sub ExtractData()
    
    Const sName As String = "Sheet1"
    Const sFirstCellAddress As String = "A3"
    
    Const dName As String = "Sheet1"
    Const dFirstCellAddress As String = "D3"
    
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
    Dim sData As Variant
    Dim srCount As Long
    With sws.Range(sFirstCellAddress).CurrentRegion
        srCount = .Rows.Count - 1
        sData = .Resize(srCount).Offset(1).Value
    End With
    
    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    dict.CompareMode = vbTextCompare
    
    Dim drCount As Long
    Dim r As Long
    Dim pString As String
    Dim cString As String
    
    For r = 1 To srCount
        cString = CStr(sData(r, 1))
        If Len(cString) > 0 Then
            If cString <> pString Then
                If Not dict.Exists(cString) Then
                    Set dict(cString) = New Collection
                End If
                pString = cString
            End If
        End If
        dict(pString).Add sData(r, 2)
        If dict(pString).Count > drCount Then drCount = dict(pString).Count
    Next r
    
    drCount = drCount + 1
    Dim dcCount As Long: dcCount = dict.Count
    
    Dim dData As Variant: ReDim dData(1 To drCount, 1 To dict.Count)
    
    Dim Key As Variant, Item As Variant
    Dim c As Long
    
    For Each Key In dict.Keys
        r = 1
        c = c + 1
        dData(r, c) = Key
        For Each Item In dict(Key)
            r = r + 1
            dData(r, c) = Item
        Next Item
    Next Key
    
    Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
    With dws.Range(dFirstCellAddress).Resize(, dcCount)
        .Resize(drCount).Value = dData
        .Resize(dws.Rows.Count - .Row - drCount + 1).Offset(drCount).Clear
        .Font.Bold = True
        .EntireColumn.AutoFit
    End With
    
    MsgBox "Data extracted.", vbInformation
    
End Sub