CODEWITHSUNDEEP
vbaexcel
Katia
Katia

Reputation: 53

Excel VBA Transpose and insert rows

I have Excel with >5k rows in it and code which does almost what I need, just can't figure out, how to achieve the desired result. Here is the code:

Sub TransposeInsertRows()

Dim xRg As Range
Dim i As Long, j As Long, k As Long
Dim x As Long, y As Long
Set xRg = Application.InputBox _
(Prompt:="Range Selection...", _
Title:="Transpose", Type:=8)
Application.ScreenUpdating = False
x = xRg(1, 1).Column + 2
y = xRg(1, xRg.Columns.Count).Column
For i = xRg(xRg.Rows.Count, 1).Row To xRg(1, 1).Row Step -1
    If Cells(i, x) <> "" And Cells(i, x + 1) <> "" Then
        k = Cells(i, x - 2).End(xlToRight).Column
        If k > y Then k = y
        For j = k To x + 1 Step -1
            Cells(i + 1, 1).EntireRow.Insert
            With Cells(i + 1, x - 2)
                .Value = .Offset(-1, 0)
                .Offset(0, 1) = .Offset(0, 1)
                .Offset(0, 1) = Cells(i, j)
            End With
            Cells(i, j).ClearContents
        Next j
    End If
Next i
Application.ScreenUpdating = True
End Sub

Excel table row to transpose:

01-1-01337-18 |  129 |    21 |  129-2 | 146 |   238

Desired result:

01-1-01337-18   129
01-1-01337-18   21
01-1-01337-18   129-2   
01-1-01337-18   146 
01-1-01337-18   238

Now result is:

01-1-01337-18 | 129  |  21
01-1-01337-18 | 129-2|  
01-1-01337-18 | 146  |
01-1-01337-18 | 238  |

What I'm missing?

Upvotes: 0

Views: 1361

Answers (3)

DisplayName
DisplayName

Reputation: 13386

you may want to iterate through selection rows backwards, insert rows, populate them with row transposed values and do some final cleanup:

Sub TransposeInsertRows()
    Dim xRg As Range
    Set xRg = Application.InputBox(Prompt:="Range Selection...", Title:="Transpose", Type:=8)

    Dim iRow As Long
    With xRg ' reference selected range
        For iRow = .Rows.Count To 1 Step -1 ' loop through referenced range rows backwards
            .Rows(iRow + 1).Resize(.Columns.Count - 2).Insert xlShiftDown 'insert n-2 rows down current row
            .Rows(iRow + 1).Resize(.Columns.Count - 2, 1).Value = .Rows(iRow).Cells(1, 1).Value ' populate inserted rows first column with current row first column value
            .Rows(iRow).Offset(1, 1).Resize(.Columns.Count - 2, 1).Value = Application.Transpose(.Rows(iRow).Offset(, 2).Resize(, .Columns.Count - 2).Value) ' populate inserted rows with current row values from 3rd column rightwards 
        Next
        .Columns(3).Resize(, .Columns.Count - 2).ClearContents ' clear columns we already transposed values of
        If WorksheetFunction.CountBlank(.Columns(2)) > 0 Then .Columns(2).SpecialCells(xlCellTypeBlanks).EntireRow.Delete ' delete rows associated with any missing value 
    End With
End Sub

Upvotes: 0

tigeravatar
tigeravatar

Reputation: 26640

Perhaps like this?

Sub TransposeInsertRows()

    Dim rData As Range
    Dim aData As Variant
    Dim aResults() As Variant
    Dim iyData As Long, ixData As Long
    Dim iyResult As Long

    On Error Resume Next
    Set rData = Application.InputBox(Prompt:="Range Selection...", _
                                     Title:="Transpose", _
                                     Default:=Selection.Address, _
                                     Type:=8)
    On Error GoTo 0
    If rData Is Nothing Then Exit Sub   'Pressed cancel

    If rData.Cells.Count = 1 Then
        MsgBox "Only one cell selected, not enough data to transpose and insert.  Exiting Macro."
        Exit Sub
    End If

    aData = rData.Value
    ReDim aResults(1 To rData.Rows.Count * rData.Columns.Count, 1 To 2)

    For iyData = 1 To UBound(aData, 1)
        For ixData = 2 To UBound(aData, 2)
            If Len(Trim(aData(iyData, ixData))) > 0 Then
                iyResult = iyResult + 1
                aResults(iyResult, 1) = aData(iyData, 1)
                aResults(iyResult, 2) = aData(iyData, ixData)
            End If
        Next ixData
    Next iyData

    If iyResult = 0 Then
        MsgBox "No data found to transpose in selected range [" & rData.Address & "]"
        Exit Sub
    End If

    rData.Clear
    If rData.Rows.Count < iyResult Then
        rData.Offset(1).Resize(iyResult - rData.Rows.Count - 1).EntireRow.Insert
    End If
    rData.Resize(iyResult, UBound(aResults, 2)).Value = aResults

End Sub

Upvotes: 2

newacc2240
newacc2240

Reputation: 1425

It seems that the value of x is to determine whether move data or not.

So simply change x = xRg(1, 1).Column + 2 to x = xRg(1, 1).Column + 1

And k = Cells(i, x - 2).End(xlToRight).Column changes to k = Cells(i, x - 1).End(xlToRight).Column

With Cells(i + 1, x - 2) changes to With Cells(i + 1, x - 1) should work as you wish.

Upvotes: 0

Related Questions