Envoyer des feuilles de calcul par e-mail en tant que classeurs distincts - Exemples de code VBA

Ce code enregistre une feuille de calcul en tant que nouveau classeur et crée un e-mail dans Outlook avec le nouveau classeur en pièce jointe. C'est très utile si vous avez un modèle de feuille de calcul standardisé qui est utilisé dans toute votre organisation.

Pour un exemple plus simple, regardez Comment envoyer un e-mail à partir d'Excel

Enregistrer la feuille de calcul en tant que nouveau classeur et la joindre à un e-mail

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108

Sous-Mail_Classeur()Application.DisplayAlerts = FauxApplication.enableevents = FauxApplication.ScreenUpdating = FauxApplication.Calculation = xlCalculationManualDim OutApp en tant qu'objetEstomper OutMail en tant qu'objetDim FilePath en tant que chaîneDim Project_Name en tant que chaîneDim Template_Name en tant que chaîneDim ReviewDate As StringDim SaveLocation As StringChemin sombre en tant que chaîneDim Nom en tant que chaîne'Créer des variables initialesDéfinir OutApp = CreateObject("Outlook.Application")Définir OutMail = OutApp.CreateItem(0)Project_Name = Sheets("sheet1").Range("ProjectName").ValueTemplate_Name = ActiveSheet.Name'Demande d'entrée utilisé dans l'e-mailReviewDate = InputBox(Prompt:="Indiquez la date à laquelle vous souhaitez que la soumission soit examinée.", Title:="Enter Date", Default:="MM/DD/YYYY")Si ReviewDate = "Enter Date" Ou ReviewDate = vbNullString Then GoTo endmacro'Enregistrer la feuille de calcul comme propre classeurChemin = ActiveWorkbook.CheminNom = Trim(Milieu(ActiveSheet.Name, 4, 99))Définir ws = ActiveSheetDéfinir oldWB = ThisWorkbookSaveLocation = InputBox(Invite :="Choisir le nom et l'emplacement du fichier", Titre :="Enregistrer sous", Par défaut :=CreateObject("WScript.Shell").SpecialFolders("Desktop") & "/" & Name & ". xlsx")Si Dir(SaveLocation) "" AlorsMsgBox ("Un fichier portant ce nom existe déjà. Veuillez choisir un nouveau nom ou supprimer le fichier existant.")SaveLocation = InputBox(Invite :="Choisir le nom et l'emplacement du fichier", Titre :="Enregistrer sous", Par défaut :=CreateObject("WScript.Shell").SpecialFolders("Desktop") & "/" & Name & ". xlsx")Fin siSi SaveLocation = vbNullString Then GoTo endmacro'déprotéger la feuille si nécessaireActiveSheet.Unprotect Password:="password"Définir newWB = Workbooks.Add'Ajuster l'affichageActiveWindow.Zoom = 80ActiveWindow.DisplayGridlines = False'Copier + Coller les valeursoldWB.ActiveroldWB.ActiveSheet.Cells.SelectSélection.CopienouveauWB.ActivernewWB.ActiveSheet.Cells.SelectSelection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _:=Faux, Transposer :=FauxSelection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _SkipBlanks:=False, Transpose:=FalseSelection.PasteSpecial Paste:=xlPasteValidation, Operation:=xlNone, _SkipBlanks:=False, Transpose:=False'Sélectionnez un nouveau WB et désactivez le mode cutcopynewWB.ActiveSheet.Range("A10").SélectionnezApplication.CutCopyMode = False'Enregistrer le fichiernewWB.SaveAs Filename:=SaveLocation, _Format de fichier : =xlOpenXMLWorkbook, CreateBackup :=FalseFilePath = Application.ActiveWorkbook.FullName'Reprotéger oldWBoldWB.ActiveSheet.Protect Password:="password", DrawingObjects:=True, Contents:=True, Scenarios:=True _, AllowFormattingCells:=True, AllowFormattingColumns:=True, _AllowFormattingRows : = True'E-mailEn cas d'erreur Reprendre ensuiteAvec OutMail.to = "[email protected]".CC = "".BCC = "".Subject = Project_Name & " : " & Template_Name & " pour examen".Body = "Nom du projet : " & Project_Name & ", " & Name & " Pour examen par " & ReviewDate.Attachments.Add (FilePath).Affichage' .Send 'Facultatif pour automatiser l'envoi d'e-mails.Terminer parEn cas d'erreur GoTo 0Définir OutMail = RienDéfinir OutApp = Rien'Terminer la macro, restaurer la mise à jour de l'écran, les calculs, etc… endmacro :Application.DisplayAlerts = TrueApplication.enableevents = VraiApplication.ScreenUpdating = TrueApplication.Calculation = xlCalculationAutomatiqueFin du sous-marin