This should re-order the values. It just maps the rows and values in an array, clears the sheet and writes the new data back in.

[VBA]Sub ReOrder_Cells()
Dim s1 As Worksheet, Cells_Used As Double, c As Range
Set s1 = Worksheets("Sheet1")
'find how many cells have values
Cells_Used = WorksheetFunction.CountA(s1.UsedRange.Cells)
'set up array to hold new co-ordinates
Dim arr()
ReDim arr(Cells_Used - 1, 1)
'for each cell with value map row and new column(which is the value)
i = 0
For Each c In s1.UsedRange.Cells
If c <> "" Then
arr(i, 0) = c.Row
arr(i, 1) = c.Value
i = i + 1
End If
Next
'clear all old data
s1.Cells.Clear
'loop in new values (on error resume next to handle any values that are not Column names)
For i = 0 To UBound(arr)
On Error Resume Next
s1.Cells(arr(i, 0), CStr(arr(i, 1))) = arr(i, 1)
On Error GoTo 0
Next
End Sub
[/VBA]