Este 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 de modelo padronizada que é usada em sua organização.
Para um exemplo mais simples, veja Como enviar e-mail do Excel
Salvar planilha como nova pasta de trabalho e anexar ao e-mail
| 123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108 | Sub Mail_Workbook ()Application.DisplayAlerts = FalseApplication.enableevents = FalseApplication.ScreenUpdating = FalseApplication.Calculation = xlCalculationManualDim OutApp como objetoDim OutMail como objetoDim FilePath As StringDim Project_Name As StringDim Template_Name As StringDim ReviewDate As StringDim SaveLocation As StringDim Path As StringDim Name As String'Criar variáveis iniciaisDefinir OutApp = CreateObject ("Outlook.Application")Definir OutMail = OutApp.CreateItem (0)Project_Name = Sheets ("sheet1"). Range ("ProjectName"). ValueTemplate_Name = ActiveSheet.Name'Peça informações usadas no e-mailReviewDate = InputBox (Prompt: = "Forneça a data de quando você gostaria que o envio fosse revisado.", Title: = "Insira a data", Padrão: = "MM / DD / AAAA")If ReviewDate = "Enter Date" Or ReviewDate = vbNullString Then GoTo endmacro'Salvar planilha como sua própria pasta de trabalhoPath = ActiveWorkbook.PathName = Trim (Mid (ActiveSheet.Name, 4, 99))Definir ws = ActiveSheetDefinir oldWB = ThisWorkbookSaveLocation = InputBox (Prompt: = "Escolha o nome e localização do arquivo", Title: = "Salvar como", Padrão: = CreateObject ("WScript.Shell"). SpecialFolders ("Desktop") & "/" & Name & ". xlsx ")If Dir (SaveLocation) "" ThenMsgBox ("Já existe um arquivo com esse nome. Escolha um novo nome ou exclua o arquivo existente.")SaveLocation = InputBox (Prompt: = "Escolha o nome e localização do arquivo", Title: = "Salvar como", Padrão: = CreateObject ("WScript.Shell"). SpecialFolders ("Desktop") & "/" & Name & ". xlsx ")Fim seIf SaveLocation = vbNullString Then GoTo endmacro'desproteger folha se necessárioActiveSheet.Unprotect Password: = "senha"Definir newWB = Workbooks.Add'Ajustar a telaActiveWindow.Zoom = 80ActiveWindow.DisplayGridlines = False'Copiar + Colar ValoresoldWB.ActivateoldWB.ActiveSheet.Cells.SelectSelection.CopynewWB.ActivatenewWB.ActiveSheet.Cells.SelectSelection.PasteSpecial Paste: = xlPasteValues, Operação: = xlNone, SkipBlanks _: = Falso, Transpor: = FalsoSelection.PasteSpecial Paste: = xlPasteFormats, Operação: = xlNone, _SkipBlanks: = False, Transpose: = FalseSelection.PasteSpecial Paste: = xlPasteValidation, Operação: = xlNone, _SkipBlanks: = False, Transpose: = False'Selecione o novo WB e desligue o modo cutcopynewWB.ActiveSheet.Range ("A10"). SelecioneApplication.CutCopyMode = False'Salvar ArquivonewWB.SaveAs Filename: = SaveLocation, _FileFormat: = xlOpenXMLWorkbook, CreateBackup: = FalseFilePath = Application.ActiveWorkbook.FullName'Reproteger WB antigooldWB.ActiveSheet.Protect Password: = "password", DrawingObjects: = True, Contents: = True, Scenarios: = True _, AllowFormattingCells: = True, AllowFormattingColumns: = True, _AllowFormattingRows: = True'O emailOn Error Resume NextCom OutMail.to = "[email protected]".CC = "".BCC = "".Subject = Project_Name & ":" & Template_Name & "para revisão".Body = "Nome do projeto:" & Project_Name & "," & Name & "Para revisão por" & ReviewDate.Attachments.Add (FilePath).Exibição'.Send' Opcional para automatizar o envio de e-mail.Terminar comNo erro GoTo 0Definir OutMail = NadaDefinir OutApp = Nada'Finalizar macro, restaurar atualização de tela, cálculos, etc … endmacro:Application.DisplayAlerts = TrueApplication.enableevents = TrueApplication.ScreenUpdating = TrueApplication.Calculation = xlCalculationAutomaticEnd Sub |
