Inhaltsverzeichnis
Dieser Code speichert ein Arbeitsblatt als neue Arbeitsmappe und erstellt eine E-Mail in Outlook mit der angehängten neuen Arbeitsmappe. Es ist sehr nützlich, wenn Sie über eine standardisierte Vorlagentabelle verfügen, die in Ihrer gesamten Organisation verwendet wird.
Ein einfacheres Beispiel finden Sie unter So senden Sie E-Mails aus Excel
Arbeitsblatt als neue Arbeitsmappe speichern und an E-Mail anhängen
| 123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108 | Unter Mail_Workbook()Application.DisplayAlerts = FalseApplication.enableevents = FalseApplication.ScreenUpdating = FalseApplication.Calculation = xlCalculationManualOutApp als Objekt dimmenOutMail als Objekt dimmenDateipfad als String dimmenDim Project_Name As StringDim Template_Name als StringDim ReviewDate As StringDim SaveLocation As StringPfad als String dimmenName als String dimmen'Anfangsvariablen erstellenSet OutApp = CreateObject("Outlook.Application")Setze OutMail = OutApp.CreateItem(0)Project_Name = Sheets("sheet1").Range("ProjectName").ValueTemplate_Name = ActiveSheet.Name'Nach Eingabe fragen, die in E-Mail verwendet wirdReviewDate = InputBox(Prompt:="Geben Sie das Datum an, bis zu dem die Einreichung überprüft werden soll.", Title:="Enter Date", Default:="MM/DD/YYYY")If ReviewDate = "Enter Date" oder ReviewDate = vbNullString Then GoTo endmacro'Arbeitsblatt als eigene Arbeitsmappe speichernPfad = ActiveWorkbook.PathName = Trim (Mitte(ActiveSheet.Name, 4, 99))Set ws = ActiveSheetSet oldWB = ThisWorkbookSaveLocation = InputBox(Prompt:="Choose File Name and Location", Title:="Save As", Default:=CreateObject("WScript.Shell").SpecialFolders("Desktop") & "/" & Name & ". xlsx")Wenn Dir(Speicherort) "" ThenMsgBox ("Eine Datei mit diesem Namen existiert bereits. Bitte wählen Sie einen neuen Namen oder löschen Sie die vorhandene Datei.")SaveLocation = InputBox(Prompt:="Choose File Name and Location", Title:="Save As", Default:=CreateObject("WScript.Shell").SpecialFolders("Desktop") & "/" & Name & ". xlsx")Ende WennIf SaveLocation = vbNullString Then GoTo endmacro'Schutzfolie bei Bedarf aufhebenActiveSheet.Unprotect Password:="password"Set newWB = Workbooks.Add'Anzeige anpassenActiveWindow.Zoom = 80ActiveWindow.DisplayGridlines = False'Werte kopieren + einfügenoldWB.AktivierenoldWB.ActiveSheet.Cells.SelectAuswahl.KopieneuWB.AktivierennewWB.ActiveSheet.Cells.SelectSelection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _:=Falsch, Transponieren:=FalschSelection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _SkipBlanks:=False, Transponieren:=FalseSelection.PasteSpecial Paste:=xlPasteValidation, Operation:=xlNone, _SkipBlanks:=Falsch, Transponieren:=Falsch'Neuen WB auswählen und Cutcopy-Modus deaktivierennewWB.ActiveSheet.Range("A10").SelectApplication.CutCopyMode = False'Datei speichernnewWB.SaveAs Dateiname:=Speicherort, _FileFormat:=xlOpenXMLWorkbook, CreateBackup:=FalseFilePath = Application.ActiveWorkbook.FullName'Alte WB neu schützenoldWB.ActiveSheet.Protect Password:="password", DrawingObjects:=True, Contents:=True, Scenarios:=True _, AllowFormattingCells:=True, AllowFormattingColumns:=True, _AllowFormattingRows:=True'EmailBei Fehler Fortsetzen als nächstesMit OutMail.to = "[email protected]".CC = "".BCC = "".Subject = Project_Name & ": " & Template_Name & " zur Überprüfung".Body = "Projektname: " & Project_Name & ", " & Name & " Zur Überprüfung von " & ReviewDate.Anhänge.Hinzufügen (Dateipfad).Anzeige' .Senden 'Optional, um das Senden von E-Mails zu automatisieren.Ende mitBei Fehler GoTo 0Setze OutMail = NichtsSet OutApp = Nichts'Makro beenden, Bildschirmaktualisierung wiederherstellen, Berechnungen usw. … Endmakro:Application.DisplayAlerts = TrueApplication.enableevents = TrueApplication.ScreenUpdating = TrueApplication.Calculation = xlCalculationAutomaticEnd Sub |
