Excel VBA Transposing Table

Question

I am trying to transpose a table above (Coloured in blue) into the one at the bottom.

Could anyone please help? Using Excel VBA method to tranpose these data.

Appreciated. Thank you

I found this method from KuTools to do transpose but this method cant cover the column title. https://www.extendoffice.com/documents/excel/1172-excel-transpose-multiple-columns-into-one-column.html — Junyi, Feb 14 '19 at 15:56
To clarify, My table will always be in this format. (number of rows x number of questions) as of above is 6x12 . And i would like turn this table into a table of 72 rows, more likely to be sound as a list instead. — Junyi, Feb 14 '19 at 17:43

score 0 · Accepted Answer · 2019-02-15T09:05:21.577

This will do the trick, it doesn't transfer formats though (since that is really tedious and I wanted to avoid copying cells)

Also check out the .PasteSpecial Paste:=xlPasteFormats here

Copying is pretty slow and (soft) locks up your workstation while it's running - you can't use copy paste while it's copying.

Sub TransposeTable()

' You can also select a sheet like ThisWorkbook.Sheets("MySheet")
Set SourceWorkbook = ThisWorkbook.Sheets(1)
' You can select sheets from other open Workbooks by Application.Workbooks(1) or Application.Workbooks("MyWorkbook.xlsx") instead of ThisWorkbook
Set TargetWorkbook = ThisWorkbook.Sheets(2)

' Check the size of the source table
LastRowSource = SourceWorkbook.Cells(Rows.Count, 1).End(xlUp).Row
LastColumnSource = SourceWorkbook.Cells(1, Columns.Count).End(xlToLeft).Column

' Add more headers below
Headers = Array("Question", "Points", "Some other header", "Yet another header")
HeaderCount = UBound(Headers) + 1 ' Array indices start at 0, Cell columns and rows start at 1

Range(TargetWorkbook.Cells(1, 1), TargetWorkbook.Cells(1, HeaderCount)) = Headers ' Print headers

' Loop all columns in the first row of source table
For Each SourceColumn In Range(SourceWorkbook.Cells(1, 1), SourceWorkbook.Cells(1, LastColumnSource))
    ' Loop all rows in the first column of the source table
    For Each SourceRow In Range(SourceWorkbook.Cells(1, 1), SourceWorkbook.Cells(LastRowSource, SourceColumn.Column))
        ' Swap row and column in target and assign value to target
        TargetWorkbook.Cells(SourceColumn.Column + 1, SourceRow.Row).Value = SourceWorkbook.Cells(SourceRow.Row, SourceColumn.Column).Value
    Next SourceRow
Next SourceColumn

End Sub

EDIT: Adding updated solution based on the OP's comments.

' Set this to true if you want to delete TargetWorkbook cells before each run
Const DELETE_TARGET_CELLS = False

Sub TransposeTable()

' You can also select a sheet like ThisWorkbook.Sheets("MySheet")
Set SourceWorkbook = ThisWorkbook.Sheets(1)
' You can select sheets from other open Workbooks by Application.Workbooks(1) or Application.Workbooks("MyWorkbook.xlsx")
Set TargetWorkbook = ThisWorkbook.Sheets(2)

If DELETE_TARGET_CELLS Then TargetWorkbook.Cells.Delete

' Check the size of the source table
LastRowSource = SourceWorkbook.Cells(Rows.Count, 1).End(xlUp).Row
LastColumnSource = SourceWorkbook.Cells(1, Columns.Count).End(xlToLeft).Column

' Add more headers below
Headers = Array("Question", "Points")
HeaderCount = UBound(Headers) + 1 ' Array indices start at 0, Cell columns and rows start at 1
Range(TargetWorkbook.Cells(1, 1), TargetWorkbook.Cells(1, HeaderCount)) = Headers ' Print headers

' We need to also track last row of Target worksheet
LastRowTarget = TargetWorkbook.Cells(Rows.Count, 1).End(xlUp).Row

'Loop first column of all rows of source table, skip first row since we don't want to duplicate headers
For Each SourceRow In Range(SourceWorkbook.Cells(2, 1), SourceWorkbook.Cells(LastRowSource, 1))
    ' Loop all columns of the first row of source table
    For Each SourceColumn In Range(SourceWorkbook.Cells(1, 1), SourceWorkbook.Cells(2, LastColumnSource))
        ' Copy headers to first column of target table
        TargetWorkbook.Cells(LastRowTarget + 1, 1).Value = SourceWorkbook.Cells(1, SourceColumn.Column).Value
        ' Copy values of the source row to the second column of target table
        TargetWorkbook.Cells(LastRowTarget + 1, 2).Value = SourceWorkbook.Cells(SourceRow.Row, SourceColumn.Column).Value
        ' Update last row number of target table so we don't overwrite finished target rows
        LastRowTarget = TargetWorkbook.Cells(Rows.Count, 1).End(xlUp).Row
    Next SourceColumn
Next SourceRow

End Sub

Thanks, appreciated it a lot. But i would like to transpose it into a matrix (n x 2 columns) for example number of rows = 6 (without headers) x all the scores below. So with the sample provided, transposing a 6 rows / 12 columns of data into a 72 rows / 2 columns data. I am trying to amend your script as well — Junyi, Feb 14 '19 at 17:40

score 0 · Answer 2 · answered Feb 14 '19 at 16:27

0

Since a programmatic answer has been already provided I will give you the dummy answer that I wouldn't give normally but that I think that can be useful for you in other situations where it happens you something similar.

If you don't know how to do something in VBA, record a macro in Excel and then take a look at the code of how it's done. Transposing a matrix is something that Excel alone can do so you can record how Excel performs the action and then look at the code.

It will not give you the best code, but it can help you to figure out how to do it :)

answered Feb 14 '19 at 16:27

user123

175
4
16

Very good point ! In case you will follow this advice take [this](https://stackoverflow.com/questions/10714251/how-to-avoid-using-select-in-excel-vba), it's dangerous to go alone. – Feb 14 '19 at 16:48
Great idea. I did managed to record some for tranposing, but the looping part to change the matrix was my main trouble. – Junyi Feb 14 '19 at 17:42

Excel VBA Transposing Table

2 Answers2