Transpose Vertical to Horizontal

[samuelnjogu]

Hi guys Kindly help me with a VBA code to transpose data in column A in attached workbook in sheet named data and have it appear as it is in the sheet named results. Thanks in advance.

 

[Luke M]

Give this a shot.

Sub TransferData()
    Dim wsDest As Worksheet
    Dim wsSource As Worksheet
    Dim rngSource As Range
    Dim lastRow As Long
    Dim lngCounter As Long
    Dim recCounter As Long
   
   
    'What sheets are we dealing with?
    Set wsSource = Worksheets("data")
    Set wsDest = ThisWorkbook.Worksheets.Add
   
    Application.ScreenUpdating = False
   
    lngCounter = 1
    recCounter = 2
    With wsSource
        lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
       
        Do
            If .Cells(lngCounter, 1).IndentLevel = 0 Then
                'We have a new league
                wsDest.Cells(recCounter, "A").Value = .Cells(lngCounter, "A").Value
               
                lngCounter = lngCounter + 2
            Else
                'New game
                Set rngSource = .Cells(lngCounter, 1).Resize(7, 1)
                rngSource.Copy
                wsDest.Cells(recCounter, 1).PasteSpecial Paste:=xlPasteValues, Transpose:=True
               
                lngCounter = lngCounter + 10
               
            End If
            recCounter = recCounter + 1
           
            'Loop until we reach end of data
        Loop Until lngCounter > lastRow
    End With
   
    With wsDest
        'Remove extra column
        .Range("D:D").EntireColumn.Delete
       
        'Apply formatting
        .Range("A:A").NumberFormat = "d/m/yyyy"
        .Range("B:B").NumberFormat = "hh:mm"
        .Range("E:E").NumberFormat = "0.00"
       
        'Put date in A1
        .Range("A1").Value = Date
        .Range("A1").NumberFormat = "dddd dd/mm/yy"
       
        'Adjust column widths
        .Range("D1").EntireColumn.AutoFit
        .Range("F1").EntireColumn.AutoFit
       
        'Apply borders
        .UsedRange.Borders.LineStyle = xlContinuous
       
    End With
   
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
       
End Sub

 

[samuelnjogu]

Luke M you are the man!!!!!!! A million thank you......