What I am trying to do -
I am trying to write a macro that creates an email, attaches file A from a list and file B from another list, and sends it to 4 recipients that change for each email and set of files. There are 200+ files and 100+ recipients. Each file is different and most of the recipients are different as well. The number of emails i need to send match the data in each row.
For example, row 1 is one email, the files that need to go in it are in row 1 column P and row 1 column Q, the recipients are in row 1 as well in columns T, U, and V, and a constant email that doesn't change in cell W1.
The second email would be row 2, attaching files from column P row 2 and column Q row 2, the recipients for this email would be in row 2 columns T, U, and V, along with the constant email in cell W1.
Etc....
Here is the code i have written that is not working. It continues to loop through the column V and doesn't change the other criterias. Please help me fix the code i have if possible otherwise a solution at all if greatly appreciated.
Sub SendEmails()
'=================================================================================
Dim DtRNG As Range, Dt As Range
Set DtRNG = Sheets("Sheet1").Range("P:P").SpecialCells(xlConstants)
For Each Dt In DtRNG
'=================================================================================
Dim SummaryRNG As Range, Summary As Range
Set SummaryRNG = Sheets("Sheet1").Range("Q:Q").SpecialCells(xlConstants)
For Each Summary In SummaryRNG
'=================================================================================
Dim DMRNG As Range, DM As Range
Set DMRNG = Sheets("Sheet1").Range("T:T").SpecialCells(xlConstants)
For Each DM In DMRNG
'=================================================================================
Dim RMRNG As Range, RM As Range
Set RMRNG = Sheets("Sheet1").Range("U:U").SpecialCells(xlConstants)
For Each RM In RMRNG
'=================================================================================
Dim VPRNG As Range, VP As Range
Set VPRNG = Sheets("Sheet1").Range("V:V").SpecialCells(xlConstants)
For Each VP In VPRNG
'=================================================================================
'OPENS FILE Q
ChDir "I:\ACCOUNTING\WebSend"
Workbooks.Open Filename:="I:\ACCOUNTING\WebSend\" & Summary & ".xls"
'OPENS FILE P
ChDir "I:\ACCOUNTING\WebSend"
Workbooks.Open Filename:="I:\ACCOUNTING\WebSend\" & Dt & ".xls"
Dim OutApp As Object
Dim OutMail As Object
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.to = "" & DM & ""
.CC = "" & RM & "" & ";" & " " & "" & VP & "" ' also add the constant email but i was unsure how
.BCC = ""
.Body = ""
.Attachments.Add ActiveWorkbook.FullName ' adds the first attachment (unsure how to add all open workbooks)
'If you want to tell me a better way feel free otherwise this works for now as far as the attachments are concerned.
End With
'SAVES THE NAME OF THE FILE SO IT CAN BE ADDED TO THE SUBJECT LINE LATER
Let X = ActiveWorkbook.FullName
Windows("" & Summary & ".xls").Activate
With OutMail
.Subject = "Emailing: " & Mid(X, 23, 30) & "" & "" & Mid(ActiveWorkbook.FullName, 23, 30) & ""
.Attachments.Add ActiveWorkbook.FullName
.Display
.send
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
Windows("" & Dt & ".xls").Close
Windows("" & Summary & ".xls").Close
'This part loops over and over again for each constant in range set earlier for VP
'but i need each range VP RM DM Summary and Detail to go to the next constant and repeat not just
'the VP range.
Next VP
Next RM
Next DM
Next Summary
Next Dt
End Sub
Bookmarks