Ron de Bruin
Can you help with your code please
I cannot lock any of the worksheets that have @ in Cell B1, because if I do
the whole sheet becomes hyperlinked and as soon as I click anywhere onto it,
it opens outlook and prepares the send. Can you edit this code that it
deselects B1 after send on every sheet that has @ and move the curser to
select A1 or C1 at the end of the process



Your Email Code to be edited

Sub Mail_Every_Worksheet()
'Working in 2000-2007
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
FileExtStr = ".xlsm": FileFormatNum = 52
End If

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


Set OutApp = CreateObject("Outlook.Application")
OutApp.Session.Logon

For Each sh In ThisWorkbook.Worksheets
If sh.Range("B1").Value 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("B1").Value
.CC = ""
.BCC = ""
.Subject = "Your Roster for the Week"
.Body = "Please Confirm if this is correct"
.Attachments.Add wb.FullName
'You can add other files also like this
'.Attachments.Add ("C:\test.txt")
.Display 'or use .Send
End With

On Error GoTo 0
Range("A1").Select
.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

Just before the line Next Sh insert a line as below to select Range("C1").
Is this what you are looking for ?

sh.Range("A1").Select
Next sh

If this post helps click Yes
---------------
Jacob Skaria


"aussiegirlone" wrote:

Ron de Bruin
Can you help with your code please
I cannot lock any of the worksheets that have @ in Cell B1, because if I do
the whole sheet becomes hyperlinked and as soon as I click anywhere onto it,
it opens outlook and prepares the send. Can you edit this code that it
deselects B1 after send on every sheet that has @ and move the curser to
select A1 or C1 at the end of the process



Your Email Code to be edited

Sub Mail_Every_Worksheet()
'Working in 2000-2007
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
FileExtStr = ".xlsm": FileFormatNum = 52
End If

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


Set OutApp = CreateObject("Outlook.Application")
OutApp.Session.Logon

For Each sh In ThisWorkbook.Worksheets
If sh.Range("B1").Value 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("B1").Value
.CC = ""
.BCC = ""
.Subject = "Your Roster for the Week"
.Body = "Please Confirm if this is correct"
.Attachments.Add wb.FullName
'You can add other files also like this
'.Attachments.Add ("C:\test.txt")
.Display 'or use .Send
End With

On Error GoTo 0
Range("A1").Select
.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

Thankyou very much for helping me jacob, I had done that procedure before I
asked for help on the matter as it wasn't fixing the problem. I must have
been having a bad day yesterday that I had not realized that I had locked,
hidden, and protected that cell which prevented your solution from working.
Ron de Bruins macros are excellent codes
Thankyou once again

"Jacob Skaria" wrote:

Just before the line Next Sh insert a line as below to select Range("C1").
Is this what you are looking for ?

sh.Range("A1").Select
Next sh

If this post helps click Yes
---------------
Jacob Skaria


"aussiegirlone" wrote:

Ron de Bruin
Can you help with your code please
I cannot lock any of the worksheets that have @ in Cell B1, because if I do
the whole sheet becomes hyperlinked and as soon as I click anywhere onto it,
it opens outlook and prepares the send. Can you edit this code that it
deselects B1 after send on every sheet that has @ and move the curser to
select A1 or C1 at the end of the process



Your Email Code to be edited

Sub Mail_Every_Worksheet()
'Working in 2000-2007
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
FileExtStr = ".xlsm": FileFormatNum = 52
End If

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


Set OutApp = CreateObject("Outlook.Application")
OutApp.Session.Logon

For Each sh In ThisWorkbook.Worksheets
If sh.Range("B1").Value 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("B1").Value
.CC = ""
.BCC = ""
.Subject = "Your Roster for the Week"
.Body = "Please Confirm if this is correct"
.Attachments.Add wb.FullName
'You can add other files also like this
'.Attachments.Add ("C:\test.txt")
.Display 'or use .Send
End With

On Error GoTo 0
Range("A1").Select
.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