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
Codificação VBA facilitada
Pare de procurar códigos VBA on-line. Saiba mais sobre o AutoMacro – um construtor de código VBA que permite que os iniciantes codifiquem procedimentos do zero com o mínimo de conhecimento de codificação e com muitos recursos que economizam tempo para todos os usuários!