Data Entry Form: Macro-One To Many

I am a real macro dummy!!! Hope that a helping hand is extended. Thank you.

It is for an Account Payable Model:

2 Sheets: Payment and Database

--This is what I do----
Step 1: Cell A1: Enter Payee Name
Step 2: Cell A2: Enter Payment Reference
Step 3: Cells D2 to D6 (may go up to more than 5 bills) will automatic list.

Payment
-----A---------B----------C---------D---------E
1----XYZ Ltd----------------------------------
2----PV-1234----------------------Bill 1----
3-----------------------------------Bill 2----
4-----------------------------------Bill 3----
5-----------------------------------Bill 4----
6-----------------------------------Bill 5----


The Macro I am looking for: Transfers information of A & D to the format
below.

Database
-----A----------------B
1----PV-0123--------Earlier Bill
2----PV-0123--------Earlier Bill
3----PV-1234--------Bill 1 <------here!!!
4----PV-1234--------Bill 2
5----PV-1234--------Bill 3
6----PV-1234--------Bill 4
7----PV-1234--------Bill 5


I have attached the script in hope that it will help to pin-point exactly
what I am trying to do. (I got this from a Dave Peterson's website)


Sub UpdateLogWorksheet()

Dim historyWks As Worksheet
Dim inputWks As Worksheet

Dim nextRow As Long
Dim oCol As Long

Dim myRng As Range
Dim myCopy As String
Dim myCell As Range

'cells to copy from Input sheet - some contain formulas
myCopy = "B2,B3,B4,B5"

Set inputWks = Worksheets("Payment")
Set historyWks = Worksheets("Payment")

With historyWks
nextRow = .Cells(.Rows.Count, "K").End(xlUp).Offset(1, 0).Row
End With

With inputWks
Set myRng = .Range(myCopy)

If Application.CountA(myRng) < myRng.Cells.Count Then
MsgBox "Fill in all the cells, first!"
Range("D2").Select
Exit Sub
End If
End With

With historyWks
With .Cells(nextRow, "K")
'.Value = Now
'.NumberFormat = "mm/dd/yyyy hh:mm:ss"
'.Cells(nextRow, "B").Value = Application.UserName
oCol = 11 ' set to 1 instead of 3

For Each myCell In myRng.Cells
historyWks.Cells(nextRow, oCol).Value = myCell.Value
oCol = oCol + 1
Next myCell
End With
End With

'clear input cells that contain constants
'With inputWks
' On Error Resume Next
' With .Range(myCopy).Cells.SpecialCells(xlCellTypeConsta nts)
' .ClearContents
' Application.GoTo .Cells(1) ', Scroll:=True
' End With
' On Error GoTo 0
'End With


'Selective Clear Input Celss
With inputWks
On Error Resume Next
With Range("B2:B15,D2:D25").Cells.SpecialCells(xlCellTy peConstants)
.ClearContents
Application.GoTo .Cells(1)
Range("B2").Select

End With
On Error GoTo 0
End With



End Sub


Thank you.