Transposition and rearrangement of data using VBA

[banker]

Hi all
Please refer to the attachment provided... I need some code that will rearrange this data (in a way transpose it) by a click of a button. The outcome would be like the outcome on the outcome tab.

Basically, the code needs to start from column F5 all the way to the end..
It needs to copy this row description in cell F5 and place it in a new sheet in A3
In cell B3 in the new sheet, the code needs to copy the column Heading in I4 on this sheet (231640) and copy it in this new sheet.
In cell C4, The value of the intersect needs is to be copied here.

Similarly, this process needs to repeat itself for each Column heading from I4 to the end of the sheet for the same row description in cell f5
This is outlined in the outcomes tab as to what the code needs to generate..
It needs to do it for each row description from cell f5 to the bottom of the last record.
The data will always start from Column F4 downwards.. and columns I onwards.. columns G and H are excluded. Also Rows 1,2, and 3 will be excluded..
At all times there will only be 3 columns that is generated by the code from the source data..
Many thanks to all that can offer their solution to this problem

[JimmyTheHand]

Welcome to VBAX, Banker

Try this code:
[vba]Sub test()
Dim wsSrc As Worksheet, wsTgt As Worksheet
Dim rngOrder As Range, rngHeadings As Range, cel As Range, rngTgt As Range

Set wsSrc = Sheets("231640")
Set wsTgt = Sheets("Outcome")
Set rngOrder = wsSrc.Range("F5"): Set rngOrder = Range(rngOrder, rngOrder.End(xlDown))
Set rngHeadings = wsSrc.Range("I4"): Set rngHeadings = Range(rngHeadings, rngHeadings.End(xlToRight))

wsTgt.Range("A2") = "x"
For Each cel In rngOrder
Set rngTgt = wsTgt.Range("A" & Rows.Count).End(xlUp).Offset(1)
With rngTgt.Resize(rngHeadings.Cells.Count)
.Value = cel
.Offset(, 1) = Application.Transpose(rngHeadings)
.Offset(, 2) = Application.Transpose(Intersect(rngHeadings.EntireColumn, cel.EntireRow))
If cel.Row Mod 2 = 1 Then .EntireRow.Interior.ColorIndex = 35
End With
Next
wsTgt.Range("A2").ClearContents
End Sub
[/vba]
Note #1:
I assumed the cell A2 on the Outcome sheet was not in use, and temporarily put an "x" into the cell, which is cleared out at the end. It is necessary for properly positioning the results. If it's a problem, positioning can be done other ways, too.

Note #2
As an extra, I put in a colouring of the outcome rows for easier reading. If you don't like it, remove or modify this line:
[vba]If cel.Row Mod 2 = 1 Then .EntireRow.Interior.ColorIndex = 35[/vba]
HTH

Jimmy

[banker]

I just wanted to Thank you very much for your excellent working solution.. you deserve the express gratitude..