Option Explicit
Sub ReorgData()
' hiker95, 01/05/2012
' http://www.mrexcel.com/forum/showthread.php?t=600547
Dim lr As Long, lc As Long, r As Long, c As Long, nr As Long, n As Long, fc As Long
Dim lur As Long, luc As Long
Dim d As Range, firstaddress As String
Application.ScreenUpdating = False
lr = Cells(Rows.Count, 1).End(xlUp).Row
lc = Cells(1, 1).End(xlToRight).Column
lur = Cells.Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row
luc = Cells.Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByColumns).Column
If luc > lc Then
Range(Cells(1, lc + 3), Cells(lur, luc)).ClearContents
End If
Cells(1, lc + 3) = "RESULTS"
Cells(1, lc + 4).Resize(, lc - 1).Value = Cells(1, 2).Resize(, lc).Value
For c = 2 To lc Step 1
firstaddress = ""
With Columns(c)
Set d = .Find(1, LookIn:=xlValues, LookAt:=xlWhole)
If Not d Is Nothing Then
firstaddress = d.Address
Do
fc = 0
On Error Resume Next
fc = Application.Match(Cells(1, d.Column), Rows(1), 2)
On Error GoTo 0
If fc > 0 Then
nr = Cells(Rows.Count, fc).End(xlUp).Row + 1
Cells(nr, fc).Value = Cells(d.Row, 1).Value
End If
Set d = .FindNext(d)
Loop While Not d Is Nothing And d.Address <> firstaddress
End If
End With
Next c
Application.ScreenUpdating = True
End Sub