send email to multiple recipients

Here is what I "hammered" together (spread sheet attached); Does not look very good but works until I am listing more than one recipient in one cell:
'---------------------------------------------------------------------------------------------------------------------------------------------------
Public olApp As New Outlook.Application
Public nsMAPI As Outlook.Namespace
Public exp As Outlook.Explorer

'=========================Function CountFiles================================================================
Function CountFiles(tgtDir As String) As Integer
Dim fName As String
'Retrieve the first entry, handle error if directory not found
On Error GoTo badDirectory
fName = Dir(tgtDir & "\*.*")

On Error GoTo 0

'loop through all files in the directory and increment the function's value
Do While fName <> ""

' Ignore the current directory and
' the encompassing directory.

If fName <> "." And fName <> ".." Then
CountFiles = CountFiles + 1
End If

' Get next entry.
fName = Dir()
Loop
Exit Function

badDirectory:
'come here if directory cannot be accessed
MsgBox "The directory you specified does not exist or " & _
"cannot be accessed. Activity halted."
End



End Function

'=========================END FUNCTION COUNTFILES============================================================

Sub EmailRFQ()
Dim itmMail As Outlook.MailItem
Dim x As Variant
Dim y As Variant
Dim k As Integer
Dim RecipientName As String
Dim Manuf As String
Dim RecipientEmail As String
Dim myAttachments As Outlook.Attachments
Dim filecount As Integer
Dim strFolder As String
Dim strFileN As String
Dim mymessage As String
k = 0
filecount = 0
Filelocation = Application.ActiveWorkbook.Path
strFolder = Filelocation & "\Attachments\"
filecount = CountFiles(Filelocation & "\Attachments\")


'Return a reference to the MAPI layer
Set nsMAPI = olApp.GetNamespace("MAPI")

'Set the current cell selection equal to the e-mail address
'x = ActiveCell.Value
x = ActiveSheet.Range(Cells(1, 2), Cells(1, 2))
If x = "" Then
CreateObject("WScript.Shell").Popup "Message Is Empty ", 2
Exit Sub
End If
Do
'x = Range("b2").Value


RecipientName = Range(Cells(2 + k, 1), Cells(2 + k, 1))


RecipientEmail = Range(Cells(2 + k, 2), Cells(2 + k, 2))


Manuf = Range(Cells(2 + k, 3), Cells(2 + k, 3))
If x = "" Then Exit Do

If RecipientEmail = "" Then Exit Do


'Set the cell RecipientsSheet!b1 equal to the message body
Application.ScreenUpdating = False
Worksheets("RecipientsSheet").Activate
y = Range("b1").Value

'Create a New mail message item
Set itmMail = olApp.CreateItem(olMailItem)
Set myAttachments = itmMail.Attachments
With itmMail

'Add the subject of the mail message
.Subject = Range("a1").Value
'Create some body text
.Body = RecipientName & "," & vbNewLine & vbNewLine & _
y & vbCrLf & vbNewLine & vbNewLine & _
"Please respond to confirm ..." & vbNewLine & vbNewLine & _
"Thank you," & vbNewLine & vbNewLine & _
"My Name" & vbNewLine & _
"My Title"

'Add a recipient and test to make sure that the
'address is valid using the Resolve method

With .Recipients.Add(RecipientEmail)

.Type = olTo
If Not .Resolve Then
MsgBox "Unable to resolve address."
Exit Sub
End If
End With

'============add Attachment==================================================


strFileN = Dir(strFolder & FileType)

Do While Len(strFileN) > 0
myAttachments.Add strFolder & strFileN
strFileN = Dir
Loop

'itmMail.Display
'======================END add Attachment



.Send
End With


'Release memory
Set itmMail = Nothing
Set nsMAPI = Nothing
Set olApp = Nothing
k = k + 1
Loop
ExitProc:
Set olApp = Nothing
CreateObject("WScript.Shell").Popup "RFQ-s Sent to " & k & " Recipients", 3



1000 End Sub