Emailing rows to each different address listed.

  • Thread starter Thread starter Aaron
  • Start date Start date
A

Aaron

Hello all,

I and needing some major help. I have a file that I download to excel which
has these columns in it

PO Number
PO Line
Part Number
Description
Vendor Part Number
QTY
Due Date
Company
Company email address.

What I am needing to do is, send a email to each address with all the rows
that corresponds with that email address. There could be 1 to 100 rows per
email address. The email address does repeat on each line. I also need the
header row along with the rows that apply to each email address.

This takes me hours to do each week and would be a world of help if I could
get a macro to do this. Thanks in advance for any help you may give.

Regards,
Aaron
 
this will get you started. Open the VBA editor (ALT+F11) then add a new
module (INSERT / Module) and paste this code. What its does is to add
sheets...mail1, mail2 etc for each address

when the first loop finishes, you'll have a number of sheets called Mail1,
Mail2, ... where the address is in cell J1 of that sheet

the second loop looks at eeach sheet name beginning "Mail" and should psot
it - I just ran out of time to write this bit...but its trivial I expect
somebody can help out




Option Explicit
Private thisSheet As Worksheet
Sub splitmail()
Dim rw As Long
Dim ws As Worksheet
'collect data

rw = 2
Set thisSheet = ActiveSheet
Do Until thisSheet.Cells(rw, 1) = ""
thisSheet.Cells(rw, "J").FormulaR1C1 =
"=IF(COUNTIF(R2C9:RC[-1],RC[-1])=1,MAX(R1C10:R[-1]C)+1,VLOOKUP(RC[-1],R1C9:R[-1]C,2,FALSE))"
Set ws = Getsheet("Mail" & thisSheet.Cells(rw, "J").Value,
thisSheet.Cells(rw, "I").Value)
With ws.Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(1, 8)
.Value = thisSheet.Range(thisSheet.Cells(rw, 1), thisSheet.Cells(rw,
8)).Value
End With
rw = rw + 1
Loop

For Each ws In Worksheets
If ws.Name Like "Mail*" Then
' send sheet as mail
End If

Next



End Sub
Function Getsheet(sheetname As String, addr As String) As Worksheet
On Error Resume Next
Set Getsheet = Worksheets(sheetname)
If Err.Number <> 0 Then
Err.Clear
Set Getsheet = Worksheets.Add
With Getsheet
.Name = sheetname
.Range("A1:H1").Value = thisSheet.Range("A1:H1").Value
.Range("J1") = addr
End With
End If
 
Back
Top