Innholdsfortegnelse
Denne koden lagrer et regneark som en ny arbeidsbok og oppretter en e -post i Outlook med den nye arbeidsboken vedlagt. Det er veldig nyttig hvis du har et standardisert mal -regneark som brukes i hele organisasjonen.
For et mer enkelt eksempel, se på Slik sender du e -post fra Excel
Lagre regnearket som ny arbeidsbok og legg ved til e -post
| 123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108 | Sub Mail_Workbook ()Application.DisplayAlerts = FalskApplication.enableevents = FalskApplication.ScreenUpdating = FalskApplication.Calculation = xlCalculationManualDim OutApp som objektDim OutMail som objektDim FilePath som strengDim Project_Name As StringDim malnavn som strengDim ReviewDate As StringDim SaveLocation som strengDim Path As StringDim navn som streng'Lag innledende variablerSett OutApp = CreateObject ("Outlook.Application")Angi OutMail = OutApp.CreateItem (0)Project_Name = Sheets ("sheet1"). Område ("ProjectName"). VerdiTemplate_Name = ActiveSheet.Name'Be om inndata som brukes i e -postReviewDate = InputBox (Prompt: = "Oppgi dato når du vil at innsendingene skal gjennomgås.", Tittel: = "Skriv inn dato", Standard: = "MM/DD/ÅÅÅÅ")Hvis ReviewDate = "Enter Date" Eller ReviewDate = vbNullString, deretter GoTo endmacro'Lagre regneark som egen arbeidsbokPath = ActiveWorkbook.PathNavn = Trim (Midt (ActiveSheet.Name, 4, 99))Sett ws = ActiveSheetSett oldWB = ThisWorkbookSaveLocation = InputBox (Prompt: = "Velg filnavn og plassering", Tittel: = "Lagre som", Standard: = CreateObject ("WScript.Shell"). SpecialFolders ("Desktop") & "/" & Name & ". xlsx ")If Dir (SaveLocation) "" DaMsgBox ("En fil med det navnet eksisterer allerede. Velg et nytt navn eller slett eksisterende fil.")SaveLocation = InputBox (Prompt: = "Velg filnavn og plassering", Tittel: = "Lagre som", Standard: = CreateObject ("WScript.Shell"). SpecialFolders ("Desktop") & "/" & Name & ". xlsx ")Slutt omHvis SaveLocation = vbNullString deretter GoTo endmacro'beskyttelsesark om nødvendigActiveSheet.Unprotect Password: = "passord"Angi newWB = Workbooks.Add'Juster displayetActiveWindow.Zoom = 80ActiveWindow.DisplayGridlines = Falske'Kopier + Lim inn verdieroldWB.ActivateoldWB.ActiveSheet.Cells.SelectValg. KopinewWB.ActivatenewWB.ActiveSheet.Cells.SelectSelection.PasteSpecial Paste: = xlPasteValues, Operation: = xlNone, SkipBlanks _: = Falske, Transponer: = FalskeSelection.PasteSpecial Paste: = xlPasteFormats, Operation: = xlNone, _SkipBlanks: = False, Transpose: = FalseSelection.PasteSpecial Paste: = xlPasteValidation, Operation: = xlNone, _SkipBlanks: = False, Transpose: = False'Velg ny WB og slå av kopimodusnewWB.ActiveSheet.Range ("A10"). VelgApplication.CutCopyMode = Falsk'Lagre filennewWB.SaveAs filnavn: = SaveLocation, _FileFormat: = xlOpenXMLWorkbook, CreateBackup: = FalseFilePath = Application.ActiveWorkbook.FullName'Beskytt gamleWBoldWB.ActiveSheet.Protect Password: = "password", DrawingObjects: = True, Contents: = True, Scenarios: = True _, AllowFormattingCells: = True, AllowFormattingColumns: = True, _AllowFormattingRows: = True'E -postVed feil Fortsett nesteMed OutMail.to = "[email protected]".CC = "".BCC = "".Subject = Project_Name & ":" & Template_Name & "for review".Body = "Prosjektnavn:" & Project_Name & "," & Name & "For review by" & ReviewDate.Attachments.Add (FilePath).Vise'.Sende' Valgfritt for å automatisere sending av e -post.Slutt medVed feil GoTo 0Set OutMail = NothingSett OutApp = Ingenting'Avslutt makro, Gjenopprett skjermoppdatering, Beregninger, etc … endmacro:Application.DisplayAlerts = TrueApplication.enableevents = TrueApplication.ScreenUpdating = TrueApplication.Calculation = xlCalculationAutomaticSlutt Sub |
