Copy Multiple Column & Row Records Into Single Row Records

Sub CopyAreasToRows()

Dim lRows As Long, lCol As Long, lColCount As Long

Dim rCol As Range, lPasteRow As Long
Dim lLoopCount As Long

Dim rRange As Range, rCell As Range
Dim wsStart As Worksheet, wsTrans As Worksheet


    Set rCol = Application.InputBox(Prompt:="Select columns", _
                           Title:="TRANSPOSE ROWS", Type:=8)

                                   

    'Cancelled or non valid range
    If rCol Is Nothing Then Exit Sub
    'Set Worksheet variables
    Set wsStart = ActiveSheet
    Set wsTrans = Sheets.Add()
    On Error Resume Next
    Application.ScreenUpdating = False

  lColCount = rCol.Columns.Count
  lPasteRow = 1
    Set rRange = rCol.Range(wsStart.Cells(1, 1), wsStart.Cells(wsStart.Rows.Count, 1).End(xlUp))
            For Each rCell In rRange
               If rCell <> "" Then
                  lLoopCount = rCell.Row
                        With wsStart
                            .Range(.Cells(lLoopCount, 1), .Cells(lLoopCount, lColCount)).Copy
                        End With
                        wsTrans.Cells(lPasteRow, wsTrans.Columns.Count).End(xlToLeft)(1, 2).PasteSpecial
                        Application.CutCopyMode = False
               Else
                   lPasteRow = lPasteRow + 1
               End If
            Next rCell
    With wsTrans
      .Columns.AutoFit
      .Columns(1).Delete
    End With
    On Error GoTo 0
    Application.ScreenUpdating = True


End Sub