MS Excel and VBA: Transposing Data

This tip is submitted by Anupam Srivastava:

Transposing Data from Column to Row with a feature to start a New Row for each New Record which is identified by an empty Row:

The original dataset was stored in the same column followed by an empty row before each new group entry. The task was to bring each dataset into row format to make data analysis job easier. This is particularly useful for comparing information.
This Macro scans through the column, copies each item and paste it into different columns in the same row and begins a new row for each empty row it finds. The datasets are differentiated by empty row before new dataset begins.
To maintain consistency with the generated table, it is wise to make sure that each new dataset has the same number of data entities (items).

For users with knowledge of DB, if we consider each group to be an attribute with x number of entities, then each new attribute that you add to the original data should consist x entities to make sure that the final table gets populated in a uniform fashion.

For this Macro it is assumed that each dataset consists of 7 entities


Sub DataTranspose()

‘ Declare variable to denote column and row assignment

' Row Variable
Dim i As Integer
' Column Variable
Dim j As Integer
i = 2
j = 1


' Sheet has 218 rows of data

For i = 1 To 218
Range("A" & i).Select
Selection.Copy
Range("a" & j).Select
ActiveSheet.Paste

' Increment Row Counter to read next row
i = i + 1
Range("A" & i).Select
Selection.Copy

' Transposing Row Entry to Column
Range("B" & j).Select
ActiveSheet.Paste
i = i + 1
Range("A" & i).Select
Selection.Copy
Range("C" & j).Select
ActiveSheet.Paste
i = i + 1
Range("A" & i).Select
Selection.Copy
Range("D" & j).Select
ActiveSheet.Paste
i = i + 1
Range("A" & i).Select
Selection.Copy
Range("E" & j).Select
ActiveSheet.Paste
i = i + 1
Range("A" & i).Select
Selection.Copy
Range("F" & j).Select
ActiveSheet.Paste
i = i + 1
Range("A" & i).Select
Selection.Copy
Range("G" & j).Select
ActiveSheet.Paste
i = i + 1
Range("A" & i).Select
Selection.Copy
Range("H" & j).Select
ActiveSheet.Paste
i = i + 1
Range("A" & i).Select
Selection.Copy
Range("I" & j).Select
ActiveSheet.Paste
i = i + 1
j = j + 1
Next

End Sub


----------------------------------------------------------------------------------
Anupam Srivastava is B.Sc. (Computer Engineering) from Queen’s University, Kingston, Canada.