VBA Transpose Loop

Pictures

Will you please attach a sample Excel workbook? We are not able to work with or manipulate a picture of one and nobody wants to have to recreate your data from scratch.

1. Make sure that your sample data are REPRESENTATIVE of your real data. The use of unrepresentative data is very frustrating and can lead to long delays in reaching a solution.

2. Make sure that your desired results are also shown (mock up the results manually).

3. Make sure that all confidential data is removed or replaced with dummy data first (e.g. names, addresses, E-mails, etc.).

4. Try to avoid using merged cells as they cause lots of problems.

Please pay particular attention to point 2 (above): without an idea of your intended outcomes, it is often very difficult to offer appropriate advice.

This is a simple unpivot in Power Query. Upload your file and I will give you the solution.

If you have a real large range, an array might be faster.

Sub Maybe()
Dim i As Long
For i = 1 To Cells(Rows.Count, 3).End(xlUp).Row
Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(4).Value = Application.Transpose(Cells(i, 3).Resize(, 4).Value)
Next i
End Sub

If you are willing to use Power Query, here is a quick solution to unpivot the columns in question. Mcode below. File attached for your review.

let
Source = Excel.CurrentWorkbook(){[Name="Table1"]}[Content],
#"Unpivoted Columns" = Table.UnpivotOtherColumns(Source, {}, "Attribute", "Value"),
#"Removed Columns" = Table.RemoveColumns(#"Unpivoted Columns",{"Attribute"})
in
#"Removed Columns"

And another possibility maybe

Sub Transpose_Data_Array()
Dim a, b, i As Long, j As Long, x As Long
a = Range("C1:F" & Cells(Rows.Count, 3).End(xlUp).Row).Value
x = 0
ReDim b(UBound(a, 1) * UBound(a, 2))
For i = 1 To UBound(a, 1)
For j = 1 To UBound(a, 2)
b(x) = a(i, j)
x = x + 1
Next j
Next i
Cells(1, 1).Resize(UBound(b)) = Application.Transpose(b)
End Sub

Change that code to

Sub Transpose_Data_Loop()
Dim i As Long
Application.ScreenUpdating = False
For i = 1 To Cells(Rows.Count, 3).End(xlUp).Row
Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(4).Value = Application.Transpose(Cells(i, 3).Resize(, 4).Value)
Next i
Cells(1, 1).Delete Shift:=xlUp
Application.ScreenUpdating = True
End Sub

That way you have 2 in your repertoire.

The code in Post #4 loops through the data cell by cell and you'll end up with an empty row in Sheet2.

However, Sheet 2 ought to have headers and then you won't have that problem but since you indicated that you have an empty row, the code in post #10 will eliminate that problem. If you want, you can put headers in Sheet2 with code.

The code in Post #8 puts everything into internal memory, does it job there and then pastes it in one go.

So you can use whichever one you like, Post #8 or Post #10.

Try each one on a copy of your workbook. It would be nice if you had several thousands of rows.

That's how it usually works, within memory is faster.

Thanks for letting us know and good luck

Both as per your example in Mac sheet.

Sub Transpose_Data_Array()
Dim a, b, i As Long, j As Long, x As Long
a = Range("C2:H" & Cells(Rows.Count, 3).End(xlUp).Row).Value
x = 0
ReDim b(UBound(a, 1) * UBound(a, 2))
For i = 1 To UBound(a, 1)
For j = 1 To UBound(a, 2)
b(x) = a(i, j)
x = x + 1
Next j
Next i
Cells(2, 1).Resize(UBound(b)) = Application.Transpose(b)
End Sub

Sub Transpose_Data_Loop()
Dim i As Long
Application.ScreenUpdating = False
For i = 2 To Cells(Rows.Count, 3).End(xlUp).Row
Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(6).Value = Application.Transpose(Cells(i, 3).Resize(, 6).Value)
Next i
Application.ScreenUpdating = True
End Sub

Good to hear you've got it solved.

Good luck and stay safe