Data transfer macro

[John]

Hi Everyone,

I need a macro to transfer the data of sheet1 to sheet2 as
followd:
Datashee1:
Sheet1
ColumnA6,B6,C6; I have the data
Column D1,E1,F1; I have customers numbers, D4,E4,F4 the
currencies of these customers.
And columns D6,E6,F6 have the prices of these differente
customers.

Sheet2
I need to transfer these data in sheet2 as follow:
Column A2, I want a fix data which is "20"
Column B2, I want to transfer the currencies of (sheet1
D4,E4,F4).
Column C2, I want to transfer the customers numbers(sheet1
D1,E1,F1).
Column D2 & E2, I want to transfer the data of (Sheet1 B6
& C6).
Column F2 & G2, I want to create the fix Start & End date.

If you could have a macro to transfer, I will be greatly
thankful.
By the way, I have something that I am already using
currently:
See if you could change it as requested above.
See my current macro:

Private Sub CommandButton1_Click()
Dim iListCount As Integer, iColCount As Integer
Dim iRow As Integer
Dim rStartCell As Range

'Set a range variable to the first cell to recieve our data
'Using "End(xlUp).Offset(1, 0)" _
will give us the cell below the last entry
Set rStartCell = Sheet2.Range("A65536").End(xlUp).Offset
(1, 0)

'Loop as many times (less one) as there are entries in
our list.
'We must start from zero to use this in the Selected
Property.
For iListCount = 0 To ListBox1.ListCount - 1
If ListBox1.Selected(iListCount) = True Then 'User has
selected
ListBox1.Selected(iListCount) = False
iRow = iRow + 1
'Now loop as many times as there are columns in
MyRange
For iColCount = 0 To Range("MyRange").Columns.Count -
1
'place the selected data into the table, starting
from _
range Ax and moving across as many columns as there
are _
in the range MyRange.
rStartCell.Cells(iRow, iColCount + 1).Value = _
ListBox1.List(iListCount, iColCount)
Next iColCount
End If
Next iListCount

Set rStartCell = Nothing

End Sub

Private Sub UserForm_Click()

End Sub
===============================================
Thanks