none
VBA transpose while keeping headers RRS feed

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

    Help please~~~ 

    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

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 Sub


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

    • Marked as answer by jay.nz 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 jay.nz 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 jay.nz 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