Option Explicit
Sub ReorgData()
' hiker95, 07/16/2011
' http://www.mrexcel.com/forum/showthread.php?t=564341
Dim w1 As Worksheet, wR As Worksheet
Dim LR As Long, LC As Long, a As Long, aa As Long, LR2 As Long, NC As Long
Dim Area As Range, SR As Long, ER As Long, NR As Long, CName As String
Application.ScreenUpdating = False
'Set the variable w1 to worksheet Sheet1
Set w1 = Worksheets("Sheet1")
'If worksheet Results does NOT exist, then add the worksheet
If Not Evaluate("ISREF(Results!A1)") Then Worksheets.Add(After:=w1).Name = "Results"
'Set the variable wR to worksheet Results
Set wR = Worksheets("Results")
'If worksheet wR does exist, then clear the worksheet
wR.UsedRange.Clear
'Copy the used range of w1 to wR
w1.UsedRange.Copy wR.Range("A1")
'Find the last used row in wR in column 2 = column B
LR = wR.Cells(Rows.Count, 2).End(xlUp).Row
'Loop thru wR, column A, from the last row to row 2
' to split/separate the data into groups, Area's
For a = LR To 2 Step -1
'If the cell is NOT blank then insert a row
If wR.Cells(a, 1) <> "" Then wR.Rows(a).Insert
Next a
'Find the last column in wR in row 1
' which is equal to column J = 10
LC = wR.Cells(1, Columns.Count).End(xlToLeft).Column
'In this case/example in cell O1 put "From", in cell P1 put "To"
wR.Range(wR.Cells(1, LC + 5), wR.Cells(1, LC + 6)) = [{"From","To"}]
'Set the next row in in column O and P
NR = 1
'Loop thur each Area in column B, from B2 to the last row
For Each Area In wR.Range("B2", wR.Range("B" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeConstants).Areas
'Within each Area
With Area
'StartRrow is the first row in the Area
SR = .Row
'EndRow is equal to SR + the count of rows in the Area - 1
ER = SR + .Rows.Count - 1
'The next available blank row is NR + NR + 1
NR = NR + 1
'Loop thru the rows in each Area from the SR to ER of the Area
' FOR THE FIRST CASE (Area), ROWS 3 AND 4
For a = SR To ER Step 1
'Cells O NR, P NR, is equal to column B row a (ROW 3), column C row a (ROW 3)
wR.Cells(NR, LC + 5).Resize(, 2).Value = wR.Range("B" & a & ":C" & a).Value
'in a work column, LC + 2 = column L
' clear the column
wR.Columns(LC + 2).Resize(, 2).Clear
'Transpose the values in E3:J3 to L1
wR.Range(wR.Cells(1, LC + 2), wR.Cells(LC - 5 + 1, LC + 2)).Value = Application.Transpose(wR.Range(wR.Cells(a, 5), wR.Cells(a, LC)).Value)
'LR2 = last row in column L = ROW 6
LR2 = wR.Cells(Rows.Count, LC + 2).End(xlUp).Row
'In range "M1:M6
With wR.Range(wR.Cells(1, LC + 3), wR.Cells(LR2, LC + 3))
'put the formula =COUNTIF($L$1:L1,L1)
.FormulaR1C1 = "=COUNTIF(R1C" & LC + 2 & ":RC[-1],RC[-1])"
'change the formula to values
.Value = .Value
End With
'Loop thru M1 to M6
For aa = 1 To LR2 Step 1
'If M1 = 1, and L1 <> "NA", and L1 <> 0
If wR.Cells(aa, LC + 3) = 1 And wR.Cells(aa, LC + 2) <> "NA" And wR.Cells(aa, LC + 2) <> 0 Then
'Find the NC, next available column in the NR = ROW 2
NC = wR.Cells(NR, Columns.Count).End(xlToLeft).Column + 1
'cell Q2 = cell D3 = "HRSE1"
wR.Cells(NR, NC).Value = wR.Range("D" & a).Value
'cell R2 = cell L1 = 1.05
wR.Cells(NR, NC + 1).Value = wR.Cells(aa, LC + 2).Value
End If
Next aa
Next a
End With
Next Area
'After the new table is created, delete columns A thru N
'CName = LC + 4 = "N"
CName = Replace(Cells(1, LC + 4).Address(0, 0), 1, "")
wR.Columns("A:" & CName).Delete
'Find the last used column in the worksheet
LC = wR.Cells.Find("*", , xlValues, xlWhole, xlByColumns, xlPrevious, False).Column
'Put the titles in row 1, beginning in column 3 = "C"
For a = 3 To LC Step 2
wR.Cells(1, a).Resize(, 2) = [{"Tag","Coefficient"}]
Next a
'Set the column width for all the columns in the worksheet used range to AutoFit
wR.UsedRange.Columns.AutoFit
'Activate the wR worksheet
wR.Activate
Application.ScreenUpdating = True
End Sub
ffice
></o
argh. 
