send separate rows to all emails excel

Attached is a spread sheet with Supplier trading terms

Each row has a set of trading terms relating to a different supplier. The supplier name is located in column A which I have encrypted for confidentiality purposes.

I would like to be able to send the column headings along with the single row for each supplier as an attachment (excel file) to the suppliers email address in column T(again encrypted). The rest of the rows need to be omitted from the sheet as the suppliers should only be able to see the row relating to their own terms.

Is there a piece of coding that will allow me to do this in once click of a button?
I'd also need the email to have a standard subject and body text which will be the same for all of the emails sent.
I will be using Microsoft Outlook 2010.

Rob
DIRECT-Central-Terms-encrypted.xlsx
robmarr700Asked:
Who is Participating?
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

KimputerCommented:
Yes it's quite possible.
Using VBA code and a button, it would go through all rows and do exactly as you wish by:
Looping all rows, doing:
create a new excel file, write header, write line
save excel file
create new email with TO: (data from column T), subject (something default), attach excel file, even have some generic message body
send mail, delete file
loop again till end of rows

Only thing might be that Outlook will start throwing warning messages (which you need to click away before it can continue) due to protection from malware.

I could code it, but it will take you some time. If other experts chime in, it could be done in a jiffy.
0
robmarr700Author Commented:
Sounds so simple when you put it like that. Perhaps you could make a start and experts could chip in along the way?

Rob
0
KimputerCommented:
Sub test()


'insert code for opening excel file

'adjust activesheet/sheet 2 to ??? need answer

row_count = ActiveSheet.UsedRange.Rows.Count

For i = 3 To row_count Step 1

'insert code, create new excel file name temp folder\i.xlsx
'insert code, copy row 1 (header) to new file
'insert code, copy row i to new file
'insert code, save file, close file

emailaddress = ActiveSheet.Cells(i, 20).Value 'email address from column T

'insert code, outlook new email, attach etc
'insert code delete file

Next

End Sub

Open in new window


Maybe I have some more time later on today
0
Amazon Web Services

Are you thinking about creating an Amazon Web Services account for your business? Not sure where to start? In this course you’ll get an overview of the history of AWS and take a tour of their user interface.

robmarr700Author Commented:
That's great, hopefully some other experts will chip in in the meantime

Rob
0
KimputerCommented:
In the meantime, we are looking at sheet2 of your file. Since this macro is probably meant to be run on a blank excel file with just the code, I need to know if the file name is always the same (or you want to choose the file yourself), and if it's always sheet2 (as name), or always the only sheet, or always the first sheet?
0
robmarr700Author Commented:
The file will always be the same with sheet two used.

Rob
0
KimputerCommented:
Code so far. Header is problematic, since you merged cells, therefore there's no real one row header anymore. Do you think you can fix that, and just let it start at row 2 (right now row 3)?
If not, it just means I need 25 rows of extra code (to set the header as text, code already there, just add extra headers).

Adjust subject, adjust body and you're almost all done.
Then either make a button, assign macro, or just have it run as soon as you open this excel file (put it in the Private Sub Workbook_Open()
End Sub)

Sub test()


Dim original_wb As Workbook
Dim new_wb As Workbook

'adjust code for opening excel file
Set original_wb = Workbooks.Open("C:\Users\Kimputer\Documents\DIRECT-Central-Terms-encrypted.xlsx")

row_count = original_wb.Sheets(1).UsedRange.Rows.Count
col_count = original_wb.Sheets(1).UsedRange.Columns.Count

For i = 3 To row_count Step 1
    
    emailaddress = original_wb.Sheets(1).Cells(i, 20).Value 'email address from column T
    Set new_wb = Workbooks.Add
    
    'adjust header code
    original_wb.Sheets(1).Range("A1").EntireRow.Copy Destination:=new_wb.Sheets(1).Range("A1")

'alternative if you don't want to touch the header
    'original_wb.Sheets(1).Cells(1, 1).Value = "header1"
    'original_wb.Sheets(1).Cells(1, 2).Value = "header2"
    'all the way till
    'original_wb.Sheets(1).Cells(1, 25).Value = "header25"
    

    original_wb.Sheets(1).Range("A" & i).EntireRow.Copy Destination:=new_wb.Sheets(1).Range("A2")
    
    Application.DisplayAlerts = False
    new_wb.SaveAs Environ("temp") & "\" & i & ".xlsx"
    new_wb.Close SaveChanges:=False
    Set new_wb = Nothing
    Application.DisplayAlerts = True
    
    
    
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
    With OutMail
            .to = emailaddress
            .CC = ""
            .BCC = ""
            .Subject = "This is the Subject line" 'adjust subjectline!
            .Body = "Hi there" 'adjust body text!
            .Attachments.Add (Environ("temp") & "\" & i & ".xlsx")
            .Send
    End With
    
    Set OutMail = Nothing
    Set OutApp = Nothing
    
    Kill Environ("temp") & "\" & i & ".xlsx"

Next

End Sub

Open in new window

0
robmarr700Author Commented:
I've made the adjustments to the merged cells, hopefully this should resolve things. (see attached).
DIRECT-Central-Terms-encrypted.xlsx
0
KimputerCommented:
This is the final code then (except adjust subject line and body message, also adjust where the file will be located)
Also as said before, either make a button for this macro, or put it in the workbook_open sub
Sub test()


Dim original_wb As Workbook
Dim new_wb As Workbook


Set original_wb = Workbooks.Open("C:\Users\Kimputer\Documents\DIRECT-Central-Terms-encrypted.xlsx") 'adjust file location

row_count = original_wb.Sheets(1).UsedRange.Rows.Count
col_count = original_wb.Sheets(1).UsedRange.Columns.Count

For i = 2 To row_count Step 1
    
    emailaddress = original_wb.Sheets(1).Cells(i, 20).Value 'email address from column T
    Set new_wb = Workbooks.Add
    
    original_wb.Sheets(1).Range("A1").EntireRow.Copy Destination:=new_wb.Sheets(1).Range("A1")
    original_wb.Sheets(1).Range("A" & i).EntireRow.Copy Destination:=new_wb.Sheets(1).Range("A2")
    
    Application.DisplayAlerts = False
    new_wb.SaveAs Environ("temp") & "\" & i & ".xlsx"
    new_wb.Close SaveChanges:=False
    Set new_wb = Nothing
    Application.DisplayAlerts = True
  
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
    With OutMail
            .To = emailaddress
            .CC = ""
            .BCC = ""
            .Subject = "This is the Subject line" 'adjust subjectline!
            .Body = "Hi there" 'adjust body text!
            .Attachments.Add (Environ("temp") & "\" & i & ".xlsx")
            .Send
    End With
    
    Set OutMail = Nothing
    Set OutApp = Nothing
    
    Kill Environ("temp") & "\" & i & ".xlsx"

Next

End Sub

Open in new window

0

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
robmarr700Author Commented:
This may sound stupid but how do I change the coding so that the body of the email displays exactly as below. e.g. spacing, font, font colour etc.

Dear Supplier,

Attached are the terms/details we hold on file for your current trading terms and contact details with THS direct. Please can you confirm these details are correct by placing a 1 in cell Z3.
If there are any differences please overwrite the current terms in red font.
Once confirmed please return the complete spreadsheet to rob.marr@thstools.co.uk

These terms will be incorporated into our THS Supplier Buying Agreement (SBA) which will subsequently be sent to yourselves to sign and return.

Rob
0
KimputerCommented:
Replace in your code:

.Body = "Dear Supplier," & vbcrlf &  vbcrlf & "Attached are the terms/details we hold on file for your current trading terms and contact details with THS direct. Please can you confirm these details are correct by placing a 1 in cell Z3." & vbcrlf & "If there are any differences please overwrite the current terms in red font." & vbcrlf &  "Once confirmed please return the complete spreadsheet to rob.marr@thstools.co.uk" & vbcrlf & vbcrlf & "These terms will be incorporated into our THS Supplier Buying Agreement (SBA) which will subsequently be sent to yourselves to sign and return." & vbcrlf & vbcrlf & "Rob"

Open in new window


This is just plain text though, no font or color whatsoever, as the email will be sent in plain text too.
0
robmarr700Author Commented:
That's great. Sorry just one more thing.

Is it possible to add a piece of code so that if a cell is vacant in column T (no email address present) it just skips this row out and moves onto the next?

Rob
0
KimputerCommented:
Replace for loop code:

For i = 2 To row_count Step 1
    
    emailaddress = original_wb.Sheets(1).Cells(i, 20).Value 'email address from column T
    if emailaddress <> "" then
		Set new_wb = Workbooks.Add
		
		original_wb.Sheets(1).Range("A1").EntireRow.Copy Destination:=new_wb.Sheets(1).Range("A1")
		original_wb.Sheets(1).Range("A" & i).EntireRow.Copy Destination:=new_wb.Sheets(1).Range("A2")
		
		Application.DisplayAlerts = False
		new_wb.SaveAs Environ("temp") & "\" & i & ".xlsx"
		new_wb.Close SaveChanges:=False
		Set new_wb = Nothing
		Application.DisplayAlerts = True
	  
		Set OutApp = CreateObject("Outlook.Application")
		Set OutMail = OutApp.CreateItem(0)
		With OutMail
				.To = emailaddress
				.CC = ""
				.BCC = ""
				.Subject = "This is the Subject line" 'adjust subjectline!
				.Body = "Dear Supplier," & vbcrlf &  vbcrlf & "Attached are the terms/details we hold on file for your current trading terms and contact details with THS direct. Please can you confirm these details are correct by placing a 1 in cell Z3." & vbcrlf & "If there are any differences please overwrite the current terms in red font." & vbcrlf &  "Once confirmed please return the complete spreadsheet to rob.marr@thstools.co.uk" & vbcrlf & vbcrlf & "These terms will be incorporated into our THS Supplier Buying Agreement (SBA) which will subsequently be sent to yourselves to sign and return." & vbcrlf & vbcrlf & "Rob"
				.Attachments.Add (Environ("temp") & "\" & i & ".xlsx")
				.Send
		End With
		
		Set OutMail = Nothing
		Set OutApp = Nothing
		
		Kill Environ("temp") & "\" & i & ".xlsx"
	end if
Next

Open in new window

0
robmarr700Author Commented:
Excellent also is it possible to name the attached excel file THS Direct Trading Terms/Contact Details

Rob
0
KimputerCommented:
Replace same for loop as before:

For i = 2 To row_count Step 1
    
	attachname = "THS_Direct_Trading_Terms_Contact_Details.xlsx"
    emailaddress = original_wb.Sheets(1).Cells(i, 20).Value 'email address from column T
    if emailaddress <> "" then
		Set new_wb = Workbooks.Add
		
		original_wb.Sheets(1).Range("A1").EntireRow.Copy Destination:=new_wb.Sheets(1).Range("A1")
		original_wb.Sheets(1).Range("A" & i).EntireRow.Copy Destination:=new_wb.Sheets(1).Range("A2")
		
		Application.DisplayAlerts = False
		new_wb.SaveAs Environ("temp") & "\" & attachname
		new_wb.Close SaveChanges:=False
		Set new_wb = Nothing
		Application.DisplayAlerts = True
	  
		Set OutApp = CreateObject("Outlook.Application")
		Set OutMail = OutApp.CreateItem(0)
		With OutMail
				.To = emailaddress
				.CC = ""
				.BCC = ""
				.Subject = "This is the Subject line" 'adjust subjectline!
				.Body = "Dear Supplier," & vbcrlf &  vbcrlf & "Attached are the terms/details we hold on file for your current trading terms and contact details with THS direct. Please can you confirm these details are correct by placing a 1 in cell Z3." & vbcrlf & "If there are any differences please overwrite the current terms in red font." & vbcrlf &  "Once confirmed please return the complete spreadsheet to rob.marr@thstools.co.uk" & vbcrlf & vbcrlf & "These terms will be incorporated into our THS Supplier Buying Agreement (SBA) which will subsequently be sent to yourselves to sign and return." & vbcrlf & vbcrlf & "Rob"
				.Attachments.Add (Environ("temp") & "\" & attachname)
				.Send
		End With
		
		Set OutMail = Nothing
		Set OutApp = Nothing
		
		Kill Environ("temp") & "\" & attachname
	end if
Next

Open in new window


You may notice the file name is different than the one you wanted, but in general, filenames without spaces are less error prone.
0
robmarr700Author Commented:
Excellent great job
0
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
Microsoft Excel

From novice to tech pro — start learning today.