PDA

View Full Version : Help with worksheet loop



austenr
07-28-2015, 01:41 PM
I have been trying to figure out this for days. I have a list of email addresses in a named range on sheet1. I have code to loop thru the worksheets and copy the information on each worksheet and put it in the body of an outlook email. The problem is I think is that once it goes into the loop and goes off the sheet with the named range of email addresses, it doesn't find any data on the next sheet even though the data is there.

Currently the email is sent with nothing in the body.

Any help is greatly appreciated.



Sub SendWorksheets()
'Sends workshets to SET menbers via Outlook
Dim OutApp As Object
Dim OutMail As Object
Dim WSCount, i As Integer
Dim cell As Range
Dim rngBody As Range




Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")


On Error GoTo cleanup
WSCount = ActiveWorkbook.Worksheets.Count
For i = 1 To WSCount

For Each cell In Sheets("MasterSheet").Range("SetMemberAddress")
If cell.Value Like "?*@?*.?*" And _
LCase(Cells(cell.Row, "Z").Value) = "yes" Then


Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
'rngBody = Worksheets(i).Range(Range("A2"), .Range("H2").End(xlDown))
'Set .body = Worksheets(i).Range(.Range("A2"), .Range("H2").End(xlDown))
'Worksheets(i).Range("A1:H1600").Select
.to = cell.Value
.subject = "Travel Exceptions"
.body = ActiveSheet.Range("A2:H2").Select
'You can add files also like this
'.Attachments.Add ("C:\test.txt")
.Display 'Or use Display
End With
On Error GoTo 0
Set OutMail = Nothing
End If
Next cell
Next i

cleanup:
Set rngBody = Nothing
Set OutApp = Nothing
Application.ScreenUpdating = True
End Sub

Paul_Hossler
07-28-2015, 07:12 PM
If you replaced

.body = ActiveSheet.Range("A2:H2").Select


with


.body = Activeworkbook.workSheets(i).Range("A2:H2").Select

I'm guessing that the ActiveSheet remains the SetMemberAddress worksheet since you never (as far as I can tell) make it active

austenr
07-29-2015, 04:55 AM
That puts -1 in the body. SetMemberAddress is a named range where i get the email Address.

Aflatoon
07-29-2015, 04:59 AM
You need to remove the .Select part. And unless A2:H2 is a merged cell, you won't be able to use it as the body without looping and concatenating cell contents.

austenr
07-29-2015, 05:34 AM
The For loop is a problem i think. Can I reference a named range on a different worksheet each time thru to get the next email address to send to? Right now stepping thru the code it exits the loop at:



LCase(Cells(cell.Row, "B").Value) = "yes" Then


The goal is to get the first email address from a worksheet called "EmailAddresses" the start the loop on sheet 2 or i = 2, grab the rows A:H and put it in the body of the email, then repeat. Amended code attached and workbook.



Sub SendWorksheets()
'Sends workshets to SET menbers via Outlook
Dim OutApp As Object
Dim OutMail As Object
Dim WSCount, i As Integer
Dim cell As Range
Dim rngBody As Range




Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")


On Error GoTo cleanup
WSCount = ActiveWorkbook.Worksheets.Count
For i = 2 To WSCount

For Each cell In Sheets("EmailAddresses").Range("SetMemberAddress")
If cell.Value Like "?*@?*.?*" And _
LCase(Cells(cell.Row, "B").Value) = "yes" Then
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
ActiveWorkbook.Worksheets(i).Select
Debug.Print rngBody
Set .body = rngBody

.To = cell.Value
.subject = "Travel Exceptions"
.body.Add = ActiveWorkbook.Worksheets(i).Range("A2:H2")
Debug.Print .body
.Send 'Or use Display
End With
On Error GoTo 0
Set OutMail = Nothing
End If
Next cell
Next i

cleanup:
Set rngBody = Nothing
Set OutApp = Nothing
Application.ScreenUpdating = True
End Sub

austenr
07-29-2015, 06:34 AM
I found /ron Debruin's code to make each sheet a workbook then send it via outlook which will work for my purposes. However, still struggling with the part of looping thru a range of email addresses to send each sheet to. Currently the addresses are in Y1:Y8 of sheet1 and are in the exact order of the sheets. So Bob would get Bob's worksheet, Sam would get Sam's. I changed the For Each sh In ThisWorkbook.Worksheets in the code below, specifically the If statement to:



If Range("SetMemberAddress") Like "?*@?*.?*" Then


which throws a type mismatch error which is understandable since it is inside the array for looping thru worksheets. How do I get around the email address problem?



Sub Mail_Every_Worksheet()
'Working in Excel 2000-2013
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
Dim sh As Worksheet
Dim wb As Workbook
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim TempFilePath As String
Dim TempFileName As String
Dim OutApp As Object
Dim OutMail As Object


TempFilePath = Environ$("temp") & "\"


If Val(Application.Version) < 12 Then
'You use Excel 97-2003
FileExtStr = ".xls": FileFormatNum = -4143
Else
'You use Excel 2007-2013
FileExtStr = ".xlsm": FileFormatNum = 52
End If


With Application
.ScreenUpdating = False
.EnableEvents = False
End With


Set OutApp = CreateObject("Outlook.Application")


For Each sh In ThisWorkbook.Worksheets
'If sh.Range("Y1").Value Like "?*@?*.?*" Then
If Range("SetMemberAddress") Like "?*@?*.?*" Then
sh.Copy
Set wb = ActiveWorkbook


TempFileName = "Sheet " & sh.name & " of " _
& ThisWorkbook.name & " " & Format(Now, "dd-mmm-yy h-mm-ss")


Set OutMail = OutApp.CreateItem(0)


With wb
.SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum


On Error Resume Next
With OutMail
.To = sh.Range("Y1").Value
.CC = ""
.BCC = ""
.subject = "This is the Subject line"
.body = "Hi there"
.Attachments.Add wb.FullName
'You can add other files also like this
'.Attachments.Add ("C:\test.txt")
.Send 'or use .Display
End With
On Error GoTo 0


.Close savechanges:=False
End With

Set OutMail = Nothing


Kill TempFilePath & TempFileName & FileExtStr


End If
Next sh


Set OutApp = Nothing


With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub


Also I would want to save the workbooks to a specific folder on drive C:

Thanks

Aflatoon
07-29-2015, 07:20 AM
Try this:

Sub NewWorksheetForEachSetMember()'Splits data from Master Worksheet into separate worksheets


Dim wsMaster As Worksheet
Dim wbTemp As Workbook
Dim OutApp As Object
Dim OutMail As Object
Dim rngFilter As Range 'filter range
Dim rngUniques As Range 'Unique Range
Dim cell As Range
Dim counter As Integer
Dim rngResults As Range 'filter range
Dim TempFilePath As String
Dim TempFileName As String
Dim vAddresses
Dim FileExtStr As String
Dim FileFormatNum As Long


If Val(Application.Version) < 12 Then
'You use Excel 97-2003
FileExtStr = ".xls": FileFormatNum = -4143
Else
'You use Excel 2007-2013
FileExtStr = ".xlsm": FileFormatNum = 52
End If


' change as necessary
TempFilePath = "C:\testing\"


vAddresses = Sheets("EmailAddresses").Range("SetMemberAddress").Resize(, 2).Value


With Application
.ScreenUpdating = False
.EnableEvents = False
End With


Set OutApp = CreateObject("Outlook.Application")


Set wsMaster = ThisWorkbook.Worksheets("MasterSheet")
With wsMaster
Set rngFilter = .Range("A1", .Range("A" & .Rows.Count).End(xlUp))
Set rngResults = .Range("A1", .Range("H" & .Rows.Count).End(xlUp))


rngFilter.AdvancedFilter Action:=xlFilterInPlace, Unique:=True
Set rngUniques = .Range("A2", .Range("A" & .Rows.Count).End(xlUp)).SpecialCells(xlCellTypeVisible)


.ShowAllData


End With


counter = 1


For Each cell In rngUniques
If vAddresses(counter, 1) Like "?*@?*.?*" And _
LCase(vAddresses(counter, 2)) = "yes" Then
Set wbTemp = Workbooks.Add(xlWBATWorksheet)
wbTemp.ActiveSheet.Name = cell.Value
rngFilter.AutoFilter Field:=1, Criteria1:=cell.Value
rngResults.SpecialCells(xlCellTypeVisible).Copy Destination:=wbTemp.ActiveSheet.Range("A1")


TempFileName = TempFilePath & cell.Value & FileExtStr




Set OutMail = OutApp.CreateItem(0)




With wbTemp
.SaveAs TempFileName, FileFormat:=FileFormatNum


On Error Resume Next
With OutMail
.To = vAddresses(counter, 1)
.CC = ""
.BCC = ""
.Subject = "This is the Subject line"
.body = "Hi there"
.Attachments.Add TempFileName
'You can add other files also like this
'.Attachments.Add ("C:\test.txt")
.Send 'or use .Display
End With
On Error GoTo 0


.Close savechanges:=False


End With


Set OutMail = Nothing
End If
counter = counter + 1


Next cell


rngFilter.Parent.AutoFilterMode = False


End Sub

Aflatoon
07-29-2015, 07:31 AM
Also posted here now: http://stackoverflow.com/questions/31703329/accessing-a-named-range-outside-a-for-loop

austenr
07-29-2015, 07:43 AM
Sorry about the cross post. Should have mentioned that in my last reply. Wont happen again and sincere apologies.

The augmented code works but only for 4 of the sheets. There should be 8 of them. Also, some workbooks contain only headers and no data. Any ideas? I didnt make any changes to your original code. Thanks a bunch for what you have helped with so far.

Aflatoon
07-29-2015, 07:50 AM
That's odd - it works for all of them for me and all have data (using your sample workbook)

austenr
07-29-2015, 07:58 AM
after the first three i get an automation error on this line:

TempFileName = TempFilePath & cell.Value & FileExtStr

also the first pass thru it email two email to the first person. On the above line of code if you hover over the variables stepping thru the code the correct file path and cell.value are there when the automation error occurs then it crashes.

austenr
07-29-2015, 08:11 AM
Update: When you run it with F5 it runs correctly but when it gets to Jeffrey Thomas's sheet it tries to make 4 workbooks then it crashes with a subscript out of range error on the following lines:



If vAddresses(counter, 1) Like "?*@?*.?*" And _
LCase(vAddresses(counter, 2)) = "yes" Then


looks like it is looking for an email address in row 9 but there isnt one.

Aflatoon
07-29-2015, 08:12 AM
Not for me, as I said. It does exactly what I'd expect.

austenr
07-29-2015, 08:15 AM
please post (attach) the workbook and code you got to work.

Aflatoon
07-29-2015, 08:34 AM
It's just your workbook above with your code replaced with what I posted.

austenr
07-29-2015, 08:41 AM
hmmm...wonder about reading past the range on the addresses.