asked on

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

Kimputer

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.

robmarr700

ASKER

Sounds so simple when you put it like that. Perhaps you could make a start and experts could chip in along the way?

Rob

Kimputer

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

robmarr700

ASKER

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

Rob

Kimputer

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?

robmarr700

ASKER

The file will always be the same with sheet two used.

Rob

Kimputer

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

robmarr700

ASKER

I've made the adjustments to the merged cells, hopefully this should resolve things. (see attached).
DIRECT-Central-Terms-encrypted.xlsx

ASKER CERTIFIED SOLUTION

Kimputer

membership

This solution is only available to members.

To access this solution, you must be a member of Experts Exchange.

Start Free Trial

robmarr700

ASKER

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

Kimputer

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.

robmarr700

ASKER

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

Kimputer

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

robmarr700

ASKER

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

Rob

SOLUTION

Kimputer

membership

This solution is only available to members.

To access this solution, you must be a member of Experts Exchange.

Start Free Trial

robmarr700

ASKER

Excellent great job