• Question

• Hi experts,

I’m trying to (kind of) transpose a table while pairing two rows of column headers with each non-black 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.

Thank you.
Jay

Sub 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

Tuesday, March 17, 2020 8:35 PM

• 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 Sub

Regards, Hans Vogelaar (http://www.eileenslounge.com)

• Marked as answer by Tuesday, March 17, 2020 10:01 PM
Tuesday, March 17, 2020 9:16 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 Sub

Regards, Hans Vogelaar (http://www.eileenslounge.com)

• Marked as answer by Tuesday, March 17, 2020 10:01 PM
Tuesday, March 17, 2020 9:16 PM
• Thank you, Hans! Works perfect!

I suppose "Preserve" can only be used with "ReDim"?

Tuesday, March 17, 2020 10:07 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)

Tuesday, March 17, 2020 10:41 PM
• 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/2020

2.
y(2, k) = Format(x(2, i), "dd/mmm/yyyy")
result: 1-Mar-20

Maybe the original data was corrupt...
• Edited by Wednesday, March 18, 2020 6:31 AM
Wednesday, March 18, 2020 2:04 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 Sub

Regards, Hans Vogelaar (http://www.eileenslounge.com)

Wednesday, March 18, 2020 8:50 AM