And another...

Public Sub ChangeTable()
Dim I As Long
Dim J As Long
Dim NewSheet As Worksheet
Dim iRow As Long
Dim vaNewTable() As Variant
Dim vaOldTable As Variant
Dim iLastRow As Long
Dim iLastColumn As Integer
iLastRow = Cells(Range("A:A").Rows.Count, 2).End(xlUp).Row
iLastColumn = Cells(1, Range("1:1").Columns.Count).End(xlToLeft).Column
vaOldTable = Range(Cells(2, 2), Cells(iLastRow, iLastColumn)).Value
Dim vaWeek As Variant
Dim vaActivity As Variant
vaWeek = Range(Cells(1, 2), Cells(1, iLastColumn))
vaActivity = Range(Cells(2, 1), Cells(iLastRow, 1))
For I = 1 To UBound(vaWeek, 2)
For J = 1 To UBound(vaActivity, 1)
If vaOldTable(J, I) < "" Then
iRow = iRow + 1
ReDim Preserve vaNewTable(3, iRow)
vaNewTable(3, iRow) = vaOldTable(J, I)
vaNewTable(2, iRow) = vaActivity(J, 1)
vaNewTable(1, iRow) = vaWeek(1, I)
End If
Next J
Next I
Set NewSheet = Worksheets.Add
NewSheet.Name = "Sheet" & ActiveWorkbook.Worksheets.Count
Range("A1").Value = "Desc"
Range("B1").Value = "Activity"
Range("C1").Value = "Qty"
Range("A2").Resize(UBound(vaNewTable, 2), UBound(vaNewTable, 1)) = _
WorksheetFunction.Transpose(vaNewTable)
End Sub

Good luck from mainland Australia:-)

Ken Johnson