VBA – Enviar planilhas por e-mail como pastas de trabalho separadas

Esse código salva uma planilha como uma nova pasta de trabalho e cria um e-mail no Outlook com a nova pasta de trabalho anexada. É muito útil se você tiver uma planilha modelo padronizada que é usada em toda a sua organização.

Para obter um exemplo mais simples, consulte Como enviar e-mail do Excel.

Salvar Planilha como Nova Pasta de Trabalho e Anexar ao E-Mail

Sub EMail_PastaDeTrabalho()
Application.DisplayAlerts = False
Application.enableevents = False
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual


Dim OutApp As Object
Dim OutMail As Object
Dim FilePath As String
Dim Project_Name As String
Dim Template_Name As String
Dim ReviewDate As String
Dim SaveLocation As String
Dim Path As String
Dim Name As String

'Criar variáveis iniciais
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
Project_Name = Sheets("Planilha1").Range("NomeDoProjeto").Value
Template_Name = ActiveSheet.Name

'Pedir entrada usada no e-mail
ReviewDate = InputBox(Prompt:="Forneça a data até a qual você gostaria que o envio fosse revisado.", Title:="Inserir Data", Default:="MM/DD/YYYYY")

If ReviewDate = "Inserir Data" Or ReviewDate = vbNullString Then GoTo endmacro

'Salvar planilha como pasta de trabalho própria
Path = ActiveWorkbook.Path
 Name = Trim(Mid(ActiveSheet.Name, 4, 99))


Set ws = ActiveSheet
Set oldWB = ThisWorkbook

SaveLocation = InputBox(Prompt:="Escolha o nome e o local do arquivo", Title:="Salvar Como", Default:=CreateObject("WScript.Shell").SpecialFolders("Desktop") & "/" & Name & ".xlsx")

 If Dir(SaveLocation) <> "" Then
 MsgBox ("Já existe um arquivo com esse nome. Escolha um novo nome ou exclua o arquivo existente.")
 SaveLocation = InputBox(Prompt:="Escolha o nome e o local do arquivo", Title:="Salvar Como", Default:=CreateObject("WScript.Shell").SpecialFolders("Desktop") & "/" & Name & ".xlsx")
 End If
    
If SaveLocation = vbNullString Then GoTo endmacro

'desproteger a planilha, se necessário
ActiveSheet.Unprotect Password:="senha"

Set newWB = Workbooks.Add

'Ajustar a exibição
ActiveWindow.Zoom = 80
ActiveWindow.DisplayGridlines = False

'Copiar + Colar Valores
oldWB.Activate
oldWB.ActiveSheet.Cells.Select
Selection.Copy
newWB.Activate
newWB.ActiveSheet.Cells.Select

 Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
 Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
 SkipBlanks:=False, Transpose:=False
 Selection.PasteSpecial Paste:=xlPasteValidation, Operation:=xlNone, _
 SkipBlanks:=False, Transpose:=False
        
     
'Selecionar novo WB e desativar o modo cutcopy
 newWB.ActiveSheet.Range("A10").Select
 Application.CutCopyMode = False
    
'Salvar arquivo
 newWB.SaveAs Filename:=SaveLocation, _
 FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False

FilePath = Application.ActiveWorkbook.FullName
    
'Reproteger oldWB
oldWB.ActiveSheet.Protect Password:="senha", DrawingObjects:=True, Contents:=True, Scenarios:=True _
, AllowFormattingCells:=True, AllowFormattingColumns:=True, _
 AllowFormattingRows:=True

'Email
On Error Resume Next
With OutMail
.to = "email@email.com"
.CC = ""
.BCC = ""
.Subject = Project_Name & ": " & Template_Name & " para revisão"
.Body = "Project Name: " & Project_Name & ", " & Name & " Para revisão de " & ReviewDate
.Attachments.Add (FilePath)
.Display
' .Send 'Opcional para automatizar o envio do e-mail.
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing

'Finalizar macro, restaurar atualização de tela, cálculos, etc.
endmacro:
Application.DisplayAlerts = True
Application.enableevents = True
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

End Sub

<<Retornar aos exemplos de VBA