Recent blog postsNavigation |
Transpose Columns with corresponsing valuesWe 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 |
Recent comments
1 week 3 days ago