Transpose using VBA

[SogK]

Hello,

I'm very new to using macros and have no clue what's going on, so i need your help!


I'm trying to create a report by transposing my data with a slight twist. The original data looks like this:
https://i.stack.imgur.com/w3nQ3.png


What i want to paste into a new sheet should look like this:
https://i.stack.imgur.com/8DGuD.png (https://i.stack.imgur.com/8DGuD.png)
The number of columns will stay locked but the number of rows will get expanded. I need a macro button to loop through rows until reaches empty. Thank you for the help!!!!!

[Kenneth Hobs]

Welcome to the forum!

The usual question is transpose the other way.

In a Module:

Sub Main()
Dim wR As Range, lR As Range, r As Range

Set wR = Range("B2", Range("B2").End(xlDown)).Resize(, 8) 'whole range of data to transpose
Set lR = Range("L1") 'L column range (1st L column's cell in transpose group)

Application.EnableEvents = False
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False

For Each r In wR.Rows
Range(r.Cells(, 1), r.Cells(, 2)).Copy lR
Set lR = lR.Offset(1)
lR.Resize(6) = [Transpose(D1:I1)]
'lR.Offset(, 1).Resize(6) = WorksheetFunction.Transpose(Range(r.Cells(, 3), r.Cells(, 8)))
Range(r.Cells(, 3), r.Cells(, 8)).Copy
lR.Offset(, 1).PasteSpecial xlPasteValuesAndNumberFormats, Transpose:=True
Set lR = lR.End(xlDown).Offset(1)
Next r

Columns("L:M").EntireColumn.AutoFit

Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
'Application.CutCopyMode = False
[L1].Activate
End Sub