Answered by:
VBA transpose while keeping headers
Question

Hi experts,
I’m trying to (kind of) transpose a table while pairing two rows of column headers with each nonblack cell.
I am very new to arrays (just started learning) and need some help/ideas/suggestions to achieve the result I want please.
Number of columns and rows are not fixed and can vary.
First table is the original, second is a desired table. Basically I would like to see a group name, a building name and a subject in one row.
I've managed to transpose the table with below code, but can't figure out where to go from here.
Help please~~~
Thank you.
JaySub test_transpose()
Dim original As Range
Dim corrected As Range
Dim x As Variant, y As Variant
Dim i As Long, j As Long, k As Long
Set original = Worksheets(1).Range("B4").CurrentRegion
Set corrected = Worksheets(2).Range("A1")
x = original
ReDim y(1 To UBound(x, 1) * UBound(x, 2), 1 To 1)
k = 0
For i = 1 To UBound(x, 2)
For j = 1 To UBound(x, 1)
k = k + 1
y(k, 1) = x(j, i)
Next j
Next i
Set corrected = corrected.Resize(rowsize:=UBound(y, 1), columnsize:=1)
corrected.Value = y
End Sub
Answers

Like this:
Sub Test_Transpose2()
Dim original As Range, corrected As Range
Dim x As Variant, y As Variant
Dim i As Long, j As Long, k As Long
Set original = Worksheets(1).Range("B4").CurrentRegion
Set corrected = Worksheets(2).Range("A1")
x = original.Value
ReDim y(1 To 3, 1 To 1)
k = 0
For i = 1 To UBound(x, 2)
For j = 3 To UBound(x, 1)
If x(j, i) <> "" Then
k = k + 1
ReDim Preserve y(1 To 3, 1 To k)
y(1, k) = x(1, i)
y(2, k) = x(2, i)
y(3, k) = x(j, i)
End If
Next j
Next i
corrected.Resize(RowSize:=UBound(y, 2), ColumnSize:=3).Value = Application.Transpose(y)
End SubRegards, Hans Vogelaar (http://www.eileenslounge.com)
 Marked as answer by jay.nz Tuesday, March 17, 2020 10:01 PM
All replies

Like this:
Sub Test_Transpose2()
Dim original As Range, corrected As Range
Dim x As Variant, y As Variant
Dim i As Long, j As Long, k As Long
Set original = Worksheets(1).Range("B4").CurrentRegion
Set corrected = Worksheets(2).Range("A1")
x = original.Value
ReDim y(1 To 3, 1 To 1)
k = 0
For i = 1 To UBound(x, 2)
For j = 3 To UBound(x, 1)
If x(j, i) <> "" Then
k = k + 1
ReDim Preserve y(1 To 3, 1 To k)
y(1, k) = x(1, i)
y(2, k) = x(2, i)
y(3, k) = x(j, i)
End If
Next j
Next i
corrected.Resize(RowSize:=UBound(y, 2), ColumnSize:=3).Value = Application.Transpose(y)
End SubRegards, Hans Vogelaar (http://www.eileenslounge.com)
 Marked as answer by jay.nz Tuesday, March 17, 2020 10:01 PM


Yes, indeed. If you ReDim an array without Preserve, all existing values will be reset (removed). With ReDim Preserve, you can enlarge (or shrink) an array while keeping the existing values.
ReDim Preserve only allows changing the last dimension, in this case the 2nd one. That's why we switch rows and columns in the y array, then use Application.Transpose to populate Sheet2 with it.
Regards, Hans Vogelaar (http://www.eileenslounge.com)

Thanks Hans!
Just one more thing.
How do you make the arrays keep the date format of the original range?
I tested below codes and the results are quite surprising.e.g 01/03/2020 as in 1st of March 2020
1.
y(2, k) = Format(x(2, i), "dd/mm/yy")
result: 3/01/20202.
Maybe the original data was corrupt...
y(2, k) = Format(x(2, i), "dd/mmm/yyyy")
result: 1Mar20 Edited by jay.nz Wednesday, March 18, 2020 6:31 AM

That is because VBA uses USA settings. Try this:
Sub Test_Transpose2()
Dim original As Range, corrected As Range
Dim x As Variant, y As Variant
Dim i As Long, j As Long, k As Long
Set original = Worksheets(1).Range("B4").CurrentRegion
Set corrected = Worksheets(2).Range("A1")
k = 0
For i = 1 To original.Columns.Count
For j = 3 To original.Rows.Count
If original(j, i) <> "" Then
k = k + 1
corrected(k, 1) = original(1, i)
corrected(k, 2) = original(2, i)
corrected(k, 3) = original(j, i)
End If
Next j
Next i
End SubRegards, Hans Vogelaar (http://www.eileenslounge.com)