Solved

send separate rows to all emails excel

Posted on 2014-12-10
16
284 Views
Last Modified: 2014-12-11
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
0
Comment
Question by:robmarr700
  • 8
  • 8
16 Comments
 
LVL 35

Expert Comment

by:Kimputer
ID: 40491031
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
 

Author Comment

by:robmarr700
ID: 40491073
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
 
LVL 35

Expert Comment

by:Kimputer
ID: 40491142
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
Live: Real-Time Solutions, Start Here

Receive instant 1:1 support from technology experts, using our real-time conversation and whiteboard interface. Your first 5 minutes are always free.

 

Author Comment

by:robmarr700
ID: 40491168
That's great, hopefully some other experts will chip in in the meantime

Rob
0
 
LVL 35

Expert Comment

by:Kimputer
ID: 40491334
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
 

Author Comment

by:robmarr700
ID: 40491362
The file will always be the same with sheet two used.

Rob
0
 
LVL 35

Expert Comment

by:Kimputer
ID: 40491432
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
 

Author Comment

by:robmarr700
ID: 40491836
I've made the adjustments to the merged cells, hopefully this should resolve things. (see attached).
DIRECT-Central-Terms-encrypted.xlsx
0
 
LVL 35

Accepted Solution

by:
Kimputer earned 500 total points
ID: 40491921
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
 

Author Comment

by:robmarr700
ID: 40493476
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
 
LVL 35

Expert Comment

by:Kimputer
ID: 40493490
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
 

Author Comment

by:robmarr700
ID: 40493500
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
 
LVL 35

Expert Comment

by:Kimputer
ID: 40493505
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
 

Author Comment

by:robmarr700
ID: 40493508
Excellent also is it possible to name the attached excel file THS Direct Trading Terms/Contact Details

Rob
0
 
LVL 35

Assisted Solution

by:Kimputer
Kimputer earned 500 total points
ID: 40493521
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
 

Author Comment

by:robmarr700
ID: 40493606
Excellent great job
0

Featured Post

Announcing the Most Valuable Experts of 2016

MVEs are more concerned with the satisfaction of those they help than with the considerable points they can earn. They are the types of people you feel privileged to call colleagues. Join us in honoring this amazing group of Experts.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

Suggested Solutions

Improved? Move/Copy Add-in Replacement - How to avoid the annoying, “A formula or sheet you want to move or copy contains the name XXX, which already exists on the destination worksheet.” David Miller (dlmille)  It was one of those days… I wa…
This code takes an Excel list of URL’s and adds a header titled “URL List”. It then searches through all URL’s in column “A”, looking for duplicates. When a duplicate is found, it is moved to the top of the list. The duplicate URL’s are then highlig…
This Micro Tutorial demonstrates how to create Excel charts: column, area, line, bar, and scatter charts. Formatting tips are provided as well.
This Micro Tutorial will demonstrate in Microsoft Excel how to add style and sexy appeal to horizontal bar charts.

815 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

8 Experts available now in Live!

Get 1:1 Help Now