Home » Blogs » ravisagar's blog

Transpose Columns with corresponsing values

Submitted by ravisagar on Tue, 07/22/2008 - 07:17.
Tags:

We have a data in the following format.

Column 1	Column 2	Column 3	Column 4
A		D				X
B		E				Y
C		F				Z
		G

There is no limit to the number of columns. Each Column has some data in the Cells below it.

The challenge is to transpose this data into this format.

A	Column 1
B	Column 1
C	Column 1
D	Column 2
E	Column 2
F	Column 2
G	Column 2
X	Column 4
Y	Column 4
Z	Column 4

Here the data below each Column is clubbed together and their respective Headers are copied in the cell next to them. If there is no value under any Header then that Column should be ignored.

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

How to use this Code
1. Create a Module and Copy the posted above.
2. Create a Sheet and name it "Output".
3. Come back to the input sheet that has the data to be transposed.
4. Run the Macro.
5. Now check the Output Sheet. It will have the transposed data.