Този код записва работен лист като нова работна книга и създава имейл в Outlook с приложената нова работна книга. Много е полезно, ако имате стандартизирана електронна таблица с шаблони, която се използва във вашата организация.
За по -прост пример вижте Как да изпращате имейл от Excel
Запазете работния лист като нова работна книга и го прикачете към имейл
| 123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108 | Sub Mail_Workbook ()Application.DisplayAlerts = FalseApplication.enableevents = FalseApplication.ScreenUpdating = FalseApplication.Calculation = xlCalculationManualЗатъмнете OutApp като обектЗатъмнете OutMail като обектЗатъмнете FilePath като низDim Project_Name As StringDim Template_Name As StringDim ReviewDate As StringЗатъмнете SaveLocation As StringЗатъмняване на пътя като низDim Name As String„Създаване на начални променливиЗадайте OutApp = CreateObject ("Outlook.Application")Задаване на OutMail = OutApp.CreateItem (0)Project_Name = Листове ("sheet1"). Обхват ("ProjectName"). СтойностTemplate_Name = ActiveSheet.Name„Поискайте въвеждане, използвано в имейлаReviewDate = InputBox (Prompt: = "Въведете дата до кога искате да се прегледа изпратеното.", Title: = "Въведете дата", по подразбиране: = "MM/DD/YYYY")Ако ReviewDate = "Въведете дата" Или ReviewDate = vbNullString След това отидете на endmacro„Запазване на работен лист като собствена работна книгаПът = ActiveWorkbook.PathИме = Подрязване (в средата (ActiveSheet.Name, 4, 99))Задайте ws = ActiveSheetЗадайте oldWB = ThisWorkbookSaveLocation = InputBox (Prompt: = "Изберете име на файл и местоположение", Title: = "Save As", По подразбиране: = CreateObject ("WScript.Shell"). SpecialFolders ("Desktop") & "/" & Name & ". xlsx ")Ако Dir (SaveLocation) "" ТогаваMsgBox ("Файл с това име вече съществува. Моля, изберете ново име или изтрийте съществуващ файл.")SaveLocation = InputBox (Prompt: = "Изберете име на файл и местоположение", Title: = "Save As", По подразбиране: = CreateObject ("WScript.Shell"). SpecialFolders ("Desktop") & "/" & Name & ". xlsx ")Край АкоАко SaveLocation = vbNullString След това отидете на endmacro„премахнете защитата на листа, ако е необходимоActiveSheet.Unprotect Password: = "парола"Задайте newWB = Работни книги'Настройте дисплеяActiveWindow.Zoom = 80ActiveWindow.DisplayGridlines = False'Копиране + Вмъкване на стойностиoldWB.АктивирайтеoldWB.ActiveSheet.Cells.SelectИзбор. КопиранеnewWB.АктивирайтеnewWB.ActiveSheet.Cells.SelectSelection.PasteSpecial Paste: = xlPasteValues, Операция: = xlNone, SkipBlanks _: = False, Транспониране: = FalseSelection.PasteSpecial Paste: = xlPasteFormats, Операция: = xlNone, _SkipBlanks: = False, Транспониране: = FalseSelection.PasteSpecial Paste: = xlPasteValidation, Операция: = xlNone, _SkipBlanks: = False, Транспониране: = False'Изберете нова WB и изключете режима за копиранеnewWB.ActiveSheet.Range ("A10"). ИзберетеApplication.CutCopyMode = False'Запишете файлаnewWB.SaveAs Име на файла: = SaveLocation, _FileFormat: = xlOpenXMLWorkbook, CreateBackup: = FalseFilePath = Application.ActiveWorkbook.FullName„Повторно защитете стария WBoldWB.ActiveSheet.Protect Password: = "парола", DrawingObjects: = True, Съдържание: = True, Сценарии: = True _, AllowFormattingCells: = True, AllowFormattingColumns: = True, _AllowFormattingRows: = Вярно'Електронна пощаНа грешка възобновяване следващоС OutMail.to = "[email protected]".CC = "".BCC = "".Subject = Project_Name & ":" & Template_Name & "за преглед".Body = "Име на проект:" & Име_на_проект & "," & Име & "За преглед от" & ReviewDate. Приложения. Добавяне (FilePath).Дисплей'. Изпрати' Незадължително за автоматизиране на изпращането на имейл.Край сПри грешка GoTo 0Задайте OutMail = НищоЗадайте OutApp = Нищо„Край на макроса, възстановяване на актуализацията на екрана, изчисляване и т.н.… endmacro:Application.DisplayAlerts = ВярноApplication.enableevents = ВярноApplication.ScreenUpdating = ВярноApplication.Calculation = xlCalculationAutomaticEnd Sub |
