Hello!
I have a macro that creates and emails each worksheet to a different end user. I want to 1) change the file name that the worksheet is saved as to the value in a cell (A1) – it currently saves as the wb name and date. 2) Find a way to password protect the new ws based on a cell value (B1) so that each sheet has a unique password.
Other info: Not every sheet has data in those fields (Macro only processes sheets that have an email address). There is a master password on the workbook, but the current macro runs fine (each new sheet is unprotected).
Here is my current code:
Thank you for your help!
I have a macro that creates and emails each worksheet to a different end user. I want to 1) change the file name that the worksheet is saved as to the value in a cell (A1) – it currently saves as the wb name and date. 2) Find a way to password protect the new ws based on a cell value (B1) so that each sheet has a unique password.
Other info: Not every sheet has data in those fields (Macro only processes sheets that have an email address). There is a master password on the workbook, but the current macro runs fine (each new sheet is unprotected).
Here is my current code:
Code:
Sub Email_Each_Sheet()
'Working in 2000-2010
Dim Source As Range
Dim Dest As Workbook
Dim wb As Workbook
Dim TempFilePath As String
Dim TempFileName As String
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim OutApp As Object
Dim OutMail As Object
For Each sht In ActiveWorkbook.Sheets
If sht.Range("A60").Value Like "?*@?*.?*" Then
sht.Activate
SendTo = sht.Range("A60").Value
Set Source = Nothing
On Error Resume Next
Set Source = Range("A2:H46").SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If Source Is Nothing Then
MsgBox "The source is not a range or the sheet is protected, " & _
"please correct and try again.", vbOKOnly
Exit Sub
End If
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Set wb = ActiveWorkbook
Set Dest = Workbooks.Add(xlWBATWorksheet)
Source.Copy
With Dest.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial Paste:=xlPasteValues
.Cells(1).PasteSpecial Paste:=xlPasteFormats
.Cells(1).Select
Application.CutCopyMode = False
ActiveWorkbook.Unprotect Password:=.Range("G3").Value
End With
TempFilePath = Environ$("temp") & "\"
TempFileName = wb.Name & " " _
& Format(Now, "mm-dd-yy")
If Val(Application.Version) < 12 Then
'You use Excel 2000-2003
FileExtStr = ".xls": FileFormatNum = 56
Else
'You use Excel 2007-2010
FileExtStr = ".xls": FileFormatNum = 56
End If
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With Dest
.SaveAs TempFilePath & TempFileName & FileExtStr, _
FileFormat:=FileFormatNum
On Error Resume Next
With OutMail
.to = SendTo
.CC = ""
.BCC = ""
.Subject = "Subject"
.body = "body."
.attachments.Add Dest.FullName
'You can add other files also like this
'.Attachments.Add ("C:\test.txt")
.Display 'or use .Send
End With
On Error GoTo 0
.Close SaveChanges:=False
End With
Kill TempFilePath & TempFileName & FileExtStr
Set OutMail = Nothing
Set OutApp = Nothing
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End If
Next
End Sub
Thank you for your help!
Last edited: