Mã này lưu trang tính dưới dạng sổ làm việc mới và tạo email trong Outlook với sổ làm việc mới được đính kèm. Sẽ rất hữu ích nếu bạn có một bảng tính mẫu chuẩn được sử dụng trong tổ chức của mình.
Để có một ví dụ đơn giản hơn, hãy xem Cách gửi Email từ Excel
Lưu Bảng tính dưới dạng Sổ làm việc Mới và Đính kèm vào Email
| 123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108 | Sub Mail_Workbook ()Application.DisplayAlerts = FalseApplication.enableevents = SaiApplication.ScreenUpdating = SaiApplication.Calculation = xlCalculationManualLàm mờ ứng dụng dưới dạng đối tượngDim OutMail As ObjectDim FilePath As StringDim Project_Name As StringDim Template_Name As StringĐánh giá mờ Ngày thành chuỗiDim SaveLocation As StringLàm mờ đường dẫn dưới dạng chuỗiDim Name As String'Tạo các biến ban đầuĐặt OutApp = CreateObject ("Outlook.Application")Đặt OutMail = OutApp.CreateItem (0)Project_Name = Sheets ("sheet1"). Range ("ProjectName"). Giá trịTemplate_Name = ActiveSheet.Name'Yêu cầu thông tin đầu vào được sử dụng trong EmailReviewDate = InputBox (Lời nhắc: = "Cung cấp ngày khi bạn muốn bài nộp được xem xét.", Title: = "Nhập ngày", Mặc định: = "MM / DD / YYYY")Nếu ReviewDate = "Nhập ngày" Hoặc ReviewDate = vbNullString thì GoTo endmacro'Lưu Trang tính làm sổ làm việc của riêng mìnhĐường dẫn = ActiveWorkbook.PathTên = Trim (Giữa (ActiveSheet.Name, 4, 99))Đặt ws = ActiveSheetĐặt oldWB = ThisWorkbookSaveLocation = InputBox (Lời nhắc: = "Chọn Tên và Vị trí Tệp", Tiêu đề: = "Lưu Dưới dạng", Mặc định: = CreateObject ("WScript.Shell"). SpecialFolders ("Máy tính để bàn") & "/" & Tên & ". xlsx ")If Dir (SaveLocation) "" Sau đóMsgBox ("Tệp có tên đó đã tồn tại. Vui lòng chọn tên mới hoặc xóa tệp hiện có.")SaveLocation = InputBox (Lời nhắc: = "Chọn Tên tệp và Vị trí", Tiêu đề: = "Lưu dưới dạng", Mặc định: = CreateObject ("WScript.Shell"). SpecialFolders ("Máy tính để bàn") & "/" & Tên & ". xlsx ")Kết thúc nếuNếu SaveLocation = vbNullString thì GoTo endmacro'bỏ bảo vệ trang tính nếu cầnActiveSheet.Unprotect Password: = "password"Đặt newWB = Workbooks.Add'Điều chỉnh màn hìnhActiveWindow.Zoom = 80ActiveWindow.DisplayGridlines = Sai'Sao chép + Dán Giá trịoldWB.ActivateoldWB.ActiveSheet.Cells.SelectLựa chọn. Sao chépnewWB.ActivatenewWB.ActiveSheet.Cells.SelectSelection.PasteSpecial Paste: = xlPasteValues, Operation: = xlNone, SkipBlanks _: = Sai, Transpose: = SaiSelection.PasteSpecial Paste: = xlPasteFormats, Operation: = xlNone, _SkipBlanks: = Sai, Transpose: = SaiSelection.PasteSpecial Paste: = xlPasteValidation, Operation: = xlNone, _SkipBlanks: = Sai, Transpose: = Sai'Chọn WB mới và tắt chế độ cắtnewWB.ActiveSheet.Range ("A10"). ChọnApplication.CutCopyMode = Sai'Lưu tập tinnewWB.SaveAs Filename: = SaveLocation, _FileFormat: = xlOpenXMLWorkbook, CreateBackup: = FalseFilePath = Application.ActiveWorkbook.FullName'Bảo vệ lại WB cũoldWB.ActiveSheet.Protect Password: = "password", DrawingObjects: = True, Contents: = True, Scenarios: = True _, AllowFormattingCells: = True, AllowFormattingColumns: = True, _AllowFormattingRows: = True'E-mailKhi có lỗi Tiếp tục tiếp theoVới OutMail.to = "[email protected]".CC = "".BCC = "".Subject = Project_Name & ":" & Template_Name & "để xem xét".Body = "Tên dự án:" & Project_Name & "," & Tên & "Để xem xét bởi" & ReviewDate.Attachments.Add (FilePath).Trưng bày'.Gửi' Tùy chọn để tự động gửi email.Kết thúc vớiLỗi GoTo 0Set OutMail = Không có gìĐặt OutApp = Không có gì'End Macro, Restore Screenupdating, Calcs, v.v. … endmacro:Application.DisplayAlerts = TrueApplication.enableevents = TrueApplication.ScreenUpdating = TrueApplication.Calculation = xlCalculationAutomaticKết thúc Sub |
