If the company name is in the filename, it is simpler than I anticipated. The following is untested with your data, but it will work if that data is as described. Column D appears to be unused?
Note that the code uses the function from http://www.rondebruin.nl/win/s1/outlook/openclose.htm to open or grab Outlook correctly. You don't want to be creating new Outlook instances for each message, and you need to open it correctly to edit the message body, which method used retains the default signature associated with the account.
The code checks that the folder exists and uses a different method to loop through the data as yours leaves an empty message open.
The code leaves all the messages open unless you re-activate .Send, so test with a smaller data set e.g. make LastRow = 4
Option Explicit
Sub SendMassEmail()
Dim lastRow As Long
Dim row_number As Long
With Sheet1
lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
For row_number = 2 To lastRow
Call SendEmail(.Range("B" & row_number), _
.Range("C" & row_number), _
.Range("E" & row_number), _
.Range("F" & row_number), _
.Range("G" & row_number), _
.Range("A" & row_number))
DoEvents
Next row_number
End With
End Sub
Sub SendEmail(what_address As String, _
carbon_copy As String, _
subject_line As String, _
mail_body As String, _
strPath As String, _
strCompany As String)
Dim olApp As Object '- Requires the code from 'http://www.rondebruin.nl/win/s1/outlook/openclose.htm
Dim olMail As Object
Dim olInsp As Object
Dim wdDoc As Object
Dim oRng As Object
Dim strFile As String
Set olApp = OutlookApp()
Set olMail = olApp.CreateItem(0)
With olMail
.To = what_address
.CC = carbon_copy
.Subject = subject_line
Set olInsp = .GetInspector
Set wdDoc = olInsp.WordEditor 'access the message body for editing
Set oRng = wdDoc.Range
oRng.Collapse 1
.Display
oRng.Text = mail_body
Do Until Right(strPath, 1) = "\"
strPath = strPath & "\"
Loop
If FolderExists(strPath) = True Then
strFile = Dir$(strPath & "*.*")
While strFile <> ""
If InStr(1, strFile, UCase(strCompany)) > 0 Then
.Attachments.Add strPath & strFile
End If
DoEvents
strFile = Dir$()
Wend
' .Send 'after testing
Else
MsgBox strPath & " does not exist!"
End If
End With
Set olApp = Nothing
Set olMail = Nothing
End Sub
Private Function FolderExists(strFolderName As String) As Boolean
'Graham Mayor
'strFolderName is the name of folder to check
Dim FSO As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
If (FSO.FolderExists(strFolderName)) Then
FolderExists = True
Else
FolderExists = False
End If
lbl_Exit:
Set FSO = Nothing
Exit Function
End Function