insert columns to rows without overwriting row header

New Contributor

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


And I want:







Any thoughts(?)

1 Reply
best response confirmed by SarahD33 (New Contributor)

@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).