Forum Discussion

SarahD33's avatar
SarahD33
Copper Contributor
Oct 25, 2022
Solved

insert columns to rows without overwriting row header

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(?)

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

     

  • SnowMan55's avatar
    SnowMan55
    Bronze 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).

     

Resources