1

i have an excel sheet that looks like the below 

    A        B       C
   1 name   company address
   2 john   apple   london
   3 jack   microsoft   kent
   4 ahmed  spacex  ca

but I need to convert it to the below 

    A
   1 name
   2 john
   3 company
   4 apple
   5 address
   6 london
   7 name
   8 jack
   9 company
   10 microsoft
   11 address
   12 kent
   13 name
   14 ahmed
   15 company
   16 spacex
   17 address
   18 ca

how can this be achieved with VBA ? the main issue seems to be duplicating the headers like the name as each name will need to have a header above it all in one column, any help would be greatly appreciated.

Improve this question
1
  • 2
    If I am reading your post right than @chillin has the best answer and if it works you should accept it. You should modify the output to look like the actual results. Please, try and post some code next time. Commented Dec 27, 2018 at 18:22

3 Answers 3

Reset to default
3

Assuming your example (in your post) is on a sheet called "Sheet2", the code will try to output the transposed array to column E (so you might want to save/make a copy before running).

Option Explicit

Private Sub TransposeWithRepeatingHeaders()

    With ThisWorkbook.Worksheets("Sheet2")

        Dim inputArray() As Variant
        inputArray = .Range("A1:C4").Value2

        Dim rowCountInOutput As Long
        ' Multiplied by two because each item will be preceded by a "header"
        rowCountInOutput = (UBound(inputArray, 1) - 1) * UBound(inputArray, 2) * 2

        Dim outputArray() As Variant
        ReDim outputArray(1 To rowCountInOutput, 1 To 1)

        Dim readRowIndex As Long
        Dim readColumnIndex As Long
        Dim writeIndex As Long

        For readRowIndex = (LBound(inputArray, 1) + 1) To UBound(inputArray, 1) ' Skip header on first row
            For readColumnIndex = LBound(inputArray, 2) To UBound(inputArray, 2)

                writeIndex = writeIndex + 1
                outputArray(writeIndex, 1) = inputArray(1, readColumnIndex) ' Assumes headers are on first row of inputArray

                writeIndex = writeIndex + 1
                outputArray(writeIndex, 1) = inputArray(readRowIndex, readColumnIndex)

            Next readColumnIndex
        Next readRowIndex

        .Range("E1").Resize(UBound(outputArray, 1), UBound(outputArray, 2)).Value2 = outputArray
    End With
End Sub

Edit: If you need to work with larger arrays/ranges, the code below might be a better approach. Presently, the stacked array will be written two columns to the right of your source data (change this if needed).

You can adjust the constant MAXIMUM_CHUNK_SIZE (the maximum number of rows to process at any given time) to see what your machine can handle. I imagine if it's too small the code will take longer to finish, and if it's too large you may experience memory issues. 10000 might be an okay starting point, I don't know.

Option Explicit

Private Sub StackWithRepeatingHeaders()

    Const MAXIMUM_CHUNK_SIZE As Long = 10000 ' More specifically, the maximum number of rows to consume per iteration

    With ThisWorkbook.Worksheets("Sheet2")
        Dim inputRange As Range
        Set inputRange = .Range("A1:Z20000") ' Include headers please

        Dim columnHeaders As Variant
        columnHeaders = Application.Index(inputRange, 1, 0)

        Dim inputColumnCount As Long
        inputColumnCount = inputRange.Columns.Count

        ' Store only the "body", as "headers" are being stored in their own array
        Set inputRange = inputRange.Offset(1, 0).Resize(inputRange.Rows.Count - 1, inputColumnCount)

        Dim inputRowCount As Long
        inputRowCount = inputRange.Rows.Count

        Dim totalOutputRowCount As Long ' Multiplied by two because each item will be preceded by a "header"
        totalOutputRowCount = inputRowCount * inputColumnCount * 2

        If totalOutputRowCount > .Rows.Count Then
            MsgBox ("There are not enough rows in this sheet to stack this range (" & Format$(totalOutputRowCount, "#,###") & " rows required). Code will stop running now.")
            Exit Sub
        End If

        Dim firstOutputCell As Range ' Stack from this cell downward
        Set firstOutputCell = .Cells(1, inputRange.Columns(inputRange.Columns.Count).Column + 2) ' +2 could error if inputrange ends near last column of sheet
    End With

    Dim outputArray() As Variant
    ReDim outputArray(1 To (MAXIMUM_CHUNK_SIZE * inputColumnCount * 2), 1 To 1)

    Dim chunkStartIndex As Long
    For chunkStartIndex = 1 To inputRowCount

        Dim currentChunkSize As Long
        currentChunkSize = Application.Min(MAXIMUM_CHUNK_SIZE, inputRowCount - chunkStartIndex + 1)

        Dim inputArray() As Variant
        inputArray = inputRange.Offset(chunkStartIndex - 1, 0).Resize(currentChunkSize, inputColumnCount).Value2 ' -1 as 0-based

        If currentChunkSize <> MAXIMUM_CHUNK_SIZE Then
            ' Think this line will only run on the last iteration (when "remaining rows" might be < MAXIMUM_CHUNK_SIZE)
            ' Avoids needless Redims
            ReDim outputArray(1 To (currentChunkSize * inputColumnCount * 2), 1 To 1)
        End If

        Dim readRowIndex As Long
        Dim readColumnIndex As Long

        Dim arrayWriteIndex As Long
        arrayWriteIndex = 0

        For readRowIndex = 1 To currentChunkSize
            For readColumnIndex = 1 To inputColumnCount

                arrayWriteIndex = arrayWriteIndex + 1
                outputArray(arrayWriteIndex, 1) = columnHeaders(1, readColumnIndex)

                arrayWriteIndex = arrayWriteIndex + 1
                outputArray(arrayWriteIndex, 1) = inputArray(readRowIndex, readColumnIndex)

            Next readColumnIndex
        Next readRowIndex

        Dim sheetWriteIndex As Long
        firstOutputCell.Offset(sheetWriteIndex, 0).Resize(UBound(outputArray, 1), UBound(outputArray, 2)).Value2 = outputArray
        sheetWriteIndex = sheetWriteIndex + (currentChunkSize * inputColumnCount * 2)

        chunkStartIndex = chunkStartIndex + currentChunkSize - 1
    Next chunkStartIndex

End Sub
Improve this answer
Sign up to request clarification or add additional context in comments.

6 Comments

many thanks chillin - your code works great but when i scale this to a sheet that goes all the way to Range("A1:J16372") i get an out of memory error 7
@MH731Z, I think one solution (for working at that scale) would be to process/consume the inputArray in chunks rather than in one go. Let me generate some dummy data on my end and get back to you.
@MH731Z, have edited answer to include some more code. Try it when you can to see whether you still experience memory issues. It might also help to close background applications whilst you run the code and/or restarting your machine before running the code.
unfortunately i get the same error even though i have over 11gb of free memory ram, also it seems to be creating one entry in column AB
@MH731Z What's weird is that I was able to run the first code on a much larger range (like 100k rows by 20 columns), so I felt the second piece of code wasn't necessary. I could process the array fine, I just couldn't write the stacked array to sheet due to insufficient rows. Try stepping through the code line by line (using F8 key on your keyboard whilst in the editor). This should show you what line causes the error. Also, check if you have any worksheet events -- or put the code from the answer and some test data (of the same scale) in a new workbook and see if you still get an error.
|
3

Try to adapt this to your worksheet names:

Sub ReConfigure()
    Dim s1 As Worksheet, s2 As Worksheet, h1 As String, h2 As String, h3 As String
    Dim i As Long, j As Long, N As Long

    Set s1 = Sheets("Sheet1")
    Set s2 = Sheets("Sheet2")
    j = 1

    With s1
        h1 = .Range("A1")
        h2 = .Range("B1")
        h3 = .Range("C1")
        N = .Cells(Rows.Count, "A").End(xlUp).Row

        For i = 2 To N
            s2.Cells(j, 1) = h1
            j = j + 1
            s2.Cells(j, 1).Value = .Cells(i, 1).Value
            j = j + 1
            s2.Cells(j, 1) = h2
            j = j + 1
            s2.Cells(j, 1).Value = .Cells(i, 2).Value
            j = j + 1
            s2.Cells(j, 1).Value = h3
            j = j + 1
            s2.Cells(j, 1).Value = .Cells(i, 3).Value
            j = j + 1
        Next i
    End With
End Sub

I am using Sheet1 for the input and Sheet2 for the output.

Improve this answer

1 Comment

thank you, how can this be changed so that it can cover columns all the way to J ?
3

you could try this (change "mySheetName" to your actual sheet name):

Sub TransposeAndDuplicateHeaders()
    Dim arr As Variant

    With Worksheets("mySheetName")
        arr = .UsedRange.Value
        .UsedRange.ClearContents

        Dim i As Long, j As Long
        For i = 2 To UBound(arr, 1)
            For j = 1 To UBound(arr, 2)
                .Cells((i - 1) * UBound(arr, 2) + (j - 1) * 2 + 1, 1).Value = arr(1, j)
                .Cells((i - 1) * UBound(arr, 2) + (j - 1) * 2 + 2, 1).Value = arr(i, j)
            Next
        Next
    End With
End Sub

Warning: this will clear the original content of "mySheetName" sheet so make a backup copy

Improve this answer

1 Comment

I tried this but also get out of memory error even though i have 11gb of free ram

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

Start asking to get answers

Find the answer to your question by asking.

Ask question

Explore related questions

See similar questions with these tags.