Transpose Columns with corresponsing values

Sub TransposeColumns()
 
Dim input_sheet As Variant
input_sheet = ActiveSheet.Name
Worksheets(input_sheet).Select
 
Dim column1, row1 As Range
' create range variables to hold row and column values
 
 
Range("IV1").End(xlToLeft).Select ' select the last column cell
 
'#####################################################################
'############### Loop till each column ###############################
 
    For Each column1 In Range(Selection, Selection.End(xlToLeft))
    ' Loop from first column to last column
        'MsgBox "Column:" & column1.Value 'Comment this later
        If column1.Offset(1, 0).Value = "" Then
        'If there is no data in column then do nothing
        Else
        'If there is some data in the first column then proceed with Transposing
 
           Worksheets(input_sheet).Select 'Select the Input sheet
 
           column1.Offset(1, 0).Select
           'Select first data which is below first Header
 
           For Each row1 In Range(Selection, Selection.End(xlDown))
            Call CopyTransposed_Output(row1.Value, column1.Value)
           Next row1
 
        End If
 
    Next column1 ' Next Column
 
Worksheets("Output").Select
Range("A1").Select
MsgBox "Transposing Columns Completed"
End Sub
 
Sub CopyTransposed_Output(row1 As Variant, column1 As Variant)
 
Worksheets("Output").Select
 
Range("A65536").End(xlUp).Select 'Move just below the last row
ActiveCell.Offset(1, 0).Value = row1
ActiveCell.Offset(1, 1).Value = column1
 
End Sub