Hey fanch,
I played around a bit with this...dump the following code into a new module and assign it to a button. You'll have rename your sheet to "OldTable" or change the sheet name in the code for the oldtable variable to match your sheet name.
Also, change the values for firstrow, lastrow, firstcolumn, and lastcolumn to match your table size.
Hope it helps...
Dan
Sub transpose()
Dim oldtable As Worksheet
Dim newtable As Worksheet
'set this sheet name to whatever your sheet name is
Set oldtable = ThisWorkbook.Sheets("OldTable"
Dim firstrow, lastrow, firstcolumn, lastcolumn
Dim temp As Variant
Dim tempcellcontents() As Variant
Dim cellcontents()
Dim v As Integer
Dim w As Integer
Dim x As Integer
Dim y As Integer
Dim z As Integer
Dim present As Boolean
Dim cellcount As Integer
Dim rowheadings() As Variant
firstrow = 1 '1st row of data
firstcolumn = 2 '1st column of data (not the leftmost column)
lastrow = 5 'or wherever your table ends vertically
lastcolumn = 5 'or wherever your table ends horizontally
'determines how many cells in table
cellcount = ((lastcolumn + 1) - firstcolumn) * ((lastrow _
+ 1) - firstrow)
'load rowheadings for later use...
ReDim rowheadings(firstrow To lastrow)
For x = firstrow To lastrow
rowheadings(x) = Cells(x, firstcolumn - 1)
Next
'load array with cell contents
ReDim tempcellcontents(1 To cellcount)
ReDim cellcontents(1 To cellcount)
z = 0
For x = firstrow To lastrow
For y = firstcolumn To lastcolumn
z = z + 1
tempcellcontents(z) = Cells(x, y)
Next
Next
'pick out unique cells for new column headings
w = 1
For z = 1 To cellcount
temp = tempcellcontents(z) 'pick each cellcontents
'one at a time
present = False ' set initial present property
' to false...
For x = 1 To w 'compare it to all the others.
If temp = cellcontents(x) Then
present = True
End If
Next
If present = False Then 'add to new cell contents
cellcontents(w) = temp
w = w + 1
End If
Next
'create new table
ActiveWorkbook.Sheets.Add
ActiveSheet.Name = "NewTable"
Set newtable = ThisWorkbook.Sheets("NewTable"
'add columnheadings
For x = 1 To w
newtable.Cells(1, x) = cellcontents(x)
Next
'fill table
v = 2
For z = 1 To w
temp = cellcontents(z)
For x = firstrow To lastrow
For y = firstcolumn To lastcolumn
If oldtable.Cells(x, y) = temp Then
Do Until newtable.Cells(v, z) = ""
v = v + 1
Loop
newtable.Cells(v, z) = oldtable.Cells _
(x, firstcolumn - 1)
v = v + 1
End If
Next
v = 2
Next
Next
End Sub
