Try this on a copy of your data:
Option Explicit
Sub ReOrganize()
'JBeaucaire (8/5/2009)
Dim LR As Long, LC As Long, i As Long
LR = Range("A" & Rows.Count).End(xlUp).Row
LC = Cells(1, Columns.Count).End(xlToLeft).Column
Application.ScreenUpdating = False
'Reformat data
For i = 4 To LC Step 2
Range(Cells(2, i), Cells(LR, i + 1)).Copy Cells(Rows.Count, "B").End(xlUp).Offset(1, 0)
Range(Cells(2, 1), Cells(LR, 1)).Copy Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
Next i
'Delete old
Range("D1", Cells(LR, LC)).ClearContents
'Sort
Columns("A:C").Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlYes, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortTextAsNumbers
'Remove blanks
LR = Range("A" & Rows.Count).End(xlUp).Row
Range("A1").AutoFilter Field:=2, Criteria1:="="
Range("A2:C" & LR).EntireRow.Delete (xlShiftUp)
Range("A1").AutoFilter
Application.ScreenUpdating = True
End Sub
Bookmarks