Transpose Columns To Rows And Insert New Rows To Fill Down Data with VBA

[Brandoe]

Hello Guys,

I want to transpose data with 5 Columns to only 2 and a new row should be created for every column.

Source Data:

[TABLE="width: 500"]
<tbody>[TR]
[TD]Berlin[/TD]
[TD]1000[/TD]
[TD]2000[/TD]
[TD]3000[/TD]
[TD]4000[/TD]
[TD]5000[/TD]
[/TR]
[TR]
[TD]Dresden[/TD]
[TD]500[/TD]
[TD]300[/TD]
[TD]300[/TD]
[TD]300[/TD]
[TD]300[/TD]
[/TR]
</tbody>[/TABLE]

After the macro, the data should be transferred to this result:

[TABLE="width: 500"]
<tbody>[TR]
[TD]Berlin[/TD]
[TD]1000[/TD]
[/TR]
[TR]
[TD]Berlin[/TD]
[TD]2000[/TD]
[/TR]
[TR]
[TD]Berlin[/TD]
[TD]3000[/TD]
[/TR]
[TR]
[TD]Berlin[/TD]
[TD]4000[/TD]
[/TR]
[TR]
[TD]Berlin[/TD]
[TD]5000[/TD]
[/TR]
[TR]
[TD]Dresden[/TD]
[TD]500[/TD]
[/TR]
[TR]
[TD]Dresden[/TD]
[TD]300[/TD]
[/TR]
[TR]
[TD]Dresden[/TD]
[TD]300[/TD]
[/TR]
[TR]
[TD]Dresden[/TD]
[TD]300[/TD]
[/TR]
[TR]
[TD]Dresden[/TD]
[TD]300[/TD]
[/TR]
</tbody>[/TABLE]

So one line per data. I found a code online, which works only for up to 3 Columns (I have 5), but I am not able to adjust it for 5 columns:

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:="Range Selection", 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(-1, 1)
                    .Offset(0, 2) = Cells(i, j)
                End With
                Cells(i, j).ClearContents
            Next j
        End If
    Next i
    Application.ScreenUpdating = True
End Sub

Can anyone help me out there? I think I miss to enhance several lines of the code, since I always get strange results.

Thanks a lot and best

Brandoe

 

[lrobbo314]

Re: How To Transpose Columns To Rows And Insert New Rows To Fill Down Data with VBA

Do you have Power Query in your version of Excel? If so, this would be as easy as adding your range as a table, without headers, and then selecting the first column and choosing the 'Unpivot Other Columns' function under the 'Transform' tab.

 

[lrobbo314]

Re: How To Transpose Columns To Rows And Insert New Rows To Fill Down Data with VBA

**delete

 

[lrobbo314]

Re: How To Transpose Columns To Rows And Insert New Rows To Fill Down Data with VBA

Here is some VBA that will do the same thing. This will clear out what you have in your original range, so test this code out on a copy to avoid losing any information.

Sub xPose()
Dim R   As Range: Set R = Range("A1").CurrentRegion
Dim IDX As Long: IDX = 0
Dim AR()


AR = R.Value


With CreateObject("Scripting.Dictionary")


    For i = 1 To UBound(AR, 1)
        For j = 2 To UBound(AR, 2)
            .Add IDX, AR(i, 1) & "-" & AR(i, j)
            IDX = IDX + 1
        Next j
    Next i
    
R.ClearContents
Set R = Range("A1").Resize(.Count, 1)
R.Value = Application.Transpose(.items)
R.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, OtherChar:="-", _
    FieldInfo:=Array(Array(1, 1), Array(2, 1)), TrailingMinusNumbers:=True
    
End With


End Sub

 

[Brandoe]

Re: How To Transpose Columns To Rows And Insert New Rows To Fill Down Data with VBA

Hello Irobbo314,

the code works fine. It posts everything in one column, but I can easily seperate them. Thanks a lot!

Brandoe