VBA Transpose with filldown

Question

I would like to do the data transpose below, with keeping the first column 'connected' to the values.

        Q1    Q2   Q3
Shop 1  100  90   110
Shop 2  90   110  130

Shop 1   Q1   100
Shop 1   Q2   90
Shop 1   Q3   110
Shop 2   Q1   90
Shop 2   Q2   110
Shop 2   Q3   130

I'm using the following code, which works perfectly for the last two column, but I'm not able to do the first column. Could anybody help, please?

Sub test()
Dim r As Range, c As Range, dest As Range

With Worksheets(“Sheet1”)
Set r = Range(.Range(“C2”), .Range(“C2”).End(xlDown))

For Each c in r

‘Sales
Range(c, c.End(xlToRight)).Copy
With Worksheets(“Sheet1”)
Set dest = .Cells(Rows.Count, “O”).End(xlUp).Offset(1, 0)
dest.PasteSpecial Transpose:=True
End With

‘Quarters
Worksheets(“Sheet1”).Range(“C1:E1”).Copy
With Worksheets(“Sheet1”)
Set dest = .Cells(Rows.Count, “N”).End(xlUp).Offset(1, 0)
dest.PasteSpecial Transpose:=True
End With

Next c

End With

End Sub

Answer 1

The trick is to consider the data as a table with a header row at the top and a header column at the left. Then for each bit of data in the "inner" table (ie the bit without headers left and top) you want to print the cell from the left, the cell above and then the data

Sub Expand(sourcerange As Range, dest As Range)
'pass this the entire table including headersas sourcerange, a single cell as dest

Dim r As Range
Dim xCol As Long  'left hand column as number
Dim yRow As Long  'top row as number
xCol = sourcerange.Cells(1, 1).Column
yRow = sourcerange.Cells(1, 1).Row
With sourcerange.Parent
For Each r In .Range(sourcerange.Cells(2, 2), .Cells(sourcerange.Rows.Count + yRow - 1, sourcerange.Columns.Count + xCol - 1))
    dest = .Cells(r.Row, xCol)
    dest.Offset(0, 1) = .Cells(yRow, r.Column)
    dest.Offset(0, 2) = r
    Set dest = dest.Offset(1, 0)
Next r
End With
End Sub