insert columns to rows without overwriting row header

[SarahD33]

I have several columns and want to transpose them to rows but insert the rows vs overwrite, is that possible? So I have

A |1|2|3

A|4|5|6

And I want:

A|1

A|2

A|3

A|4

A|5

A|6

Any thoughts(?)

[#2 · Accepted solution]

@SarahD33 I would not call your sample transformation a "transpose", as it does not result in a similar rectangle of data, but...  With a (rectangular-block) selection range like this:

... to copy the cells into one column (immediately below the selection) into new rows that are inserted like this:

(Note that the filled column in the new rows was the left-most column of the selection range.)

... requires VBA code, AFAIK:

Sub CopyCellsToIndividualNewRows()
'   This procedure copies cell values from the (rectangular-block) selection
'       range to new rows that are inserted immediately below the selection
'       -- one row for each cell -- left-to-right, top-to-bottom.

    Const strPROCEDURE_NAME = "CopyCellsToIndividualNewRows"
    
    Dim objWorksheet    As Worksheet
    Dim strSelectionRange   As String
    '
    Dim strMessage      As String
    Dim in4UserResponse As VbMsgBoxResult
    '
    Dim in4SelectionCols    As Long
    Dim in4SelectionRows    As Long
    Dim strAddrComponents() As String   'first for range address components, _
                    then for cell address components
    Dim strTopLeftAddress   As String
    Dim strBottomRightAddress   As String
    '
    Dim strSrcFirstCol  As String
    Dim strSrcLastCol   As String
    Dim in4SrcTopRow    As Long
    Dim in4SrcBottomRow As Long
    '
    Dim in4NewRows      As Long
    Dim in4DestRow      As Long
    '
    Dim in4SrcRowIteration  As Long
    Dim in4SrcColIteration  As Long
    
    '----   Capture the selection range.  Ensure that multiple,
    '       contiguous cells were selected.
    Set objWorksheet = ActiveSheet
    strSelectionRange = Selection.Address
    If InStr(1, strSelectionRange, ":") = 0 Then
        strMessage = "Sorry, but the selection must be a contiguous range."
        Call MsgBox(strMessage, vbExclamation Or vbOKOnly, strPROCEDURE_NAME)
        Exit Sub
    End If
    If InStr(1, strSelectionRange, ",") > 0 Then
        strMessage = "Sorry, but the selection must be a contiguous range."
        Call MsgBox(strMessage, vbExclamation Or vbOKOnly, strPROCEDURE_NAME)
        Exit Sub
    End If
    
    '----   Extract info from the selection range.
    in4SelectionCols = Selection.Columns.Count
    in4SelectionRows = Selection.Rows.Count
    '
    strAddrComponents = Split(strSelectionRange, ":")
    Debug.Assert UBound(strAddrComponents) = 1
    strTopLeftAddress = strAddrComponents(0)
    strBottomRightAddress = strAddrComponents(1)
    '
    strAddrComponents = Split(strTopLeftAddress, "$")
    Debug.Assert UBound(strAddrComponents) = 2
    strSrcFirstCol = strAddrComponents(1)
    in4SrcTopRow = CLng(strAddrComponents(2))
    '
    strAddrComponents = Split(strBottomRightAddress, "$")
    Debug.Assert UBound(strAddrComponents) = 2
    strSrcLastCol = strAddrComponents(1)
    in4SrcBottomRow = CLng(strAddrComponents(2))
    '  --
    in4NewRows = in4SelectionCols * in4SelectionRows
    
    '----   Insert new rows.
    Application.ScreenUpdating = False
    '
    With objWorksheet
        .Range("A" & CStr(in4SrcBottomRow + 1)).EntireRow.Select
        For in4SrcRowIteration = 1 To in4NewRows
            Selection.Insert shift:=xlShiftDown
        Next in4SrcRowIteration
    End With
    
    '----   Copy the selection-range cell values to the new rows.
    in4DestRow = in4SrcBottomRow
    With objWorksheet
        For in4SrcRowIteration = in4SrcTopRow To in4SrcBottomRow
            .Range(strSrcFirstCol & CStr(in4SrcRowIteration)).Select
            For in4SrcColIteration = 0 To in4SelectionCols - 1
                in4DestRow = in4DestRow + 1
                .Range(strSrcFirstCol & CStr(in4DestRow)).Value = _
                        Selection.Offset(0, in4SrcColIteration).Value
            Next in4SrcColIteration
        Next in4SrcRowIteration
        .Range(strSrcFirstCol & CStr(in4SrcBottomRow + 1)).Select
    End With
    '
    Application.ScreenUpdating = True
    '
    strMessage = Format$(in4NewRows, "#,###,###,##0") _
            & " cell values were copied to new rows"
    Call MsgBox(strMessage, vbInformation Or vbOKOnly, strPROCEDURE_NAME)

End Sub

Specific to this example, the code intentionally does not place content into column A of the six new rows.  Whether you want column A populated with a single "row header" value or whether you want the "row header" value to be copied from the corresponding row of each source cell, I can't tell from your sample data ... but to finish up is an easy manual copy operation either way.

I assumed that your address-list-item separator is a comma; if it is a semicolon, change the literal in line 41.

If you want to use this procedure on the content of one or more workbooks without converting them to macro-enabled workbooks, you could create this procedure in your Personal Workbook (PERSONAL.XLSB).