Macro to email to address in cell reference

[hnyb1]

Hi! I'm attempting to use Ron's code to email worksheets from excel. I've
always used this in the past to email to a particular address with much
success (thanks Ron). Now I need it to email based on the address that is
entered into a cell reference, but for whatever reason it does not work. The
new workbook is created and all tabs are there and then it just stops (no
error message, just stops working).

Please take a look at the code and tell me if there is something I'm
missing...

Sub Mail_ActiveSheet_totm()
Dim sh As Worksheet
Dim wb1 As Workbook
Dim wb2 As Workbook
Dim ws As Worksheet
Dim strdate As String
strdate = Format(Now, "yymmdd")
Application.ScreenUpdating = False

Set wb1 = ThisWorkbook
For Each ws In wb1.Worksheets
ws.Unprotect _
Password:="password"
Next ws
wb1.Sheets(Array("SR", "SV", "CLPBTAV", "FVDV", "PR", "TR", "IMC")).Copy
Set wb2 = ActiveWorkbook
For Each sh In wb2.Worksheets
wb1.Sheets(sh.Name).Cells.Copy wb2.Sheets(sh.Name).Cells(1)
Next sh
With wb2
..SaveAs "C:\" & wb2.Sheets(1).Range("R2").Value & ".xls"
..SendMail wb2.Sheets(1).Range("p9").Value, wb2.Sheets(1).Range("R1").Value
..ChangeFileAccess xlReadOnly
Kill .FullName
..Close False
End With
Application.ScreenUpdating = True
For Each ws In wb1.Worksheets
ws.Protect DrawingObjects:=True, _
Contents:=True, Scenarios:=True, _
Password:="password"
Next ws



Set wb1 = Nothing
Set ws = Nothing
End Sub

 

[Jim Thomlinson]

I notice you are susing Sheets(1) in yoru code... Very rarely is that a good
idea. the sheet that is in the first position is not always what you might
think it is. Just to debug what you are doing try adding a message box or
such to confirm that the values being returned are correct...

Sub Mail_ActiveSheet_totm()
Dim sh As Worksheet
Dim wb1 As Workbook
Dim wb2 As Workbook
Dim ws As Worksheet
Dim strdate As String
strdate = Format(Now, "yymmdd")
Application.ScreenUpdating = False

Set wb1 = ThisWorkbook
For Each ws In wb1.Worksheets
ws.Unprotect _
Password:="password"
Next ws
wb1.Sheets(Array("SR", "SV", "CLPBTAV", "FVDV", "PR", "TR", "IMC")).Copy
Set wb2 = ActiveWorkbook
For Each sh In wb2.Worksheets
wb1.Sheets(sh.Name).Cells.Copy wb2.Sheets(sh.Name).Cells(1)
Next sh
With wb2
..SaveAs "C:\" & wb2.Sheets(1).Range("R2").Value & ".xls"
msgbox wb2.Sheets(1).Range("p9").Value
msgbox wb2.Sheets(1).Range("R1").Value
..SendMail wb2.Sheets(1).Range("p9").Value, wb2.Sheets(1).Range("R1").Value
..ChangeFileAccess xlReadOnly
Kill .FullName
..Close False
End With
Application.ScreenUpdating = True
For Each ws In wb1.Worksheets
ws.Protect DrawingObjects:=True, _
Contents:=True, Scenarios:=True, _
Password:="password"
Next ws

Set wb1 = Nothing
Set ws = Nothing
End Sub