last 5 yellow highlights transpose

[makinmomb]

I have these kind of data on a1

250,000
48,000
50,000
35,000
40,000
60,000
35,000
230,000
35,000
16,000
15,000
814,000
45,000
50,000
90,000
-
200,000
140,000
210,000
65,000
800,000
144,000
40,000
5,000
-
65,000
25,000
10,000
289,000
50,000
43,000
41,000
73,000
-
200,000
10,000
10,000
427,000
43,700
106,200
5,500
2,000
2,000
0
556,000
715,400
45,400
444,000
27,000
41,000
73,000
-
240,000
5,000
10,000
15,000
70,000
48,000
1,018,400

<colgroup><col></colgroup><tbody>
</tbody>

 

[makinmomb]

1,018,400 , 715,400 , 427,000 , 289,000 and 800,000

Are in yellow highlights

I need a macro that should put to do the following

put on c1 1018400
put on d1 715400
put on e1 42700
put on f1 289000
put on g1 800000

 

[mumps]

Try:

Sub TranposeRange()
    Application.ScreenUpdating = False
    Dim LastRow As Long
    LastRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    Range("A1:A" & LastRow).AutoFilter Field:=1, Criteria1:=RGB(255, 255, 0), Operator:=xlFilterCellColor
    Range("A2:A" & LastRow).SpecialCells(xlCellTypeVisible).Copy
    Range("C1").PasteSpecial Transpose:=True
    Range("A1").AutoFilter
    Application.ScreenUpdating = True
End Sub

The macro assumes you have headers in row 1 and your data starts in row 2.

 

[makinmomb]

mumps thank you very much it is working the way i need it

 

[mumps]

You are very welcome.