Indholdsfortegnelse
Denne kode gemmer et regneark som en ny projektmappe og opretter en e -mail i Outlook med den nye projektmappe vedhæftet. Det er meget nyttigt, hvis du har et standardiseret skabelon -regneark, der bruges på tværs af din organisation.
For et mere enkelt eksempel, se Sådan sendes e -mail fra Excel
Gem regneark som ny projektmappe, og vedhæft til e -mail
| 123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108 | Sub Mail_Workbook ()Application.DisplayAlerts = FalskApplication.enableevents = FalskApplication.ScreenUpdating = FalskApplication.Calculation = xlCalculationManualDim OutApp som objektDim OutMail som objektDim FilePath som strengDim Project_Name som strengDim skabelonnavn som strengDim ReviewDate As StringDim SaveLocation som strengDæmpet sti som strengDim navn som streng'Opret indledende variablerIndstil OutApp = CreateObject ("Outlook.Application")Indstil OutMail = OutApp.CreateItem (0)Project_Name = Sheets ("sheet1"). Område ("ProjectName"). VærdiTemplate_Name = ActiveSheet.Name'Spørg efter input, der bruges i e -mailReviewDate = InputBox (Prompt: = "Angiv dato efter, hvornår du vil have indsendelsen gennemgået.", Titel: = "Indtast dato", Standard: = "MM/DD/ÅÅÅÅ")Hvis ReviewDate = "Indtast dato" Eller ReviewDate = vbNullString Så GoTo endmacro'Gem regneark som egen projektmappeSti = ActiveWorkbook.PathNavn = Trim (Midt (ActiveSheet.Name, 4, 99))Indstil ws = ActiveSheetIndstil oldWB = ThisWorkbookSaveLocation = InputBox (Prompt: = "Vælg filnavn og placering", Titel: = "Gem som", Standard: = CreateObject ("WScript.Shell"). SpecialFolders ("Desktop") & "/" & Name & ". xlsx ")Hvis Dir (SaveLocation) "" SåMsgBox ("En fil med det navn findes allerede. Vælg et nyt navn, eller slet eksisterende fil.")SaveLocation = InputBox (Prompt: = "Vælg filnavn og placering", Titel: = "Gem som", Standard: = CreateObject ("WScript.Shell"). SpecialFolders ("Desktop") & "/" & Name & ". xlsx ")Afslut HvisHvis SaveLocation = vbNullString derefter GoTo endmacro'beskyttelsesark, hvis det er nødvendigtActiveSheet.Unprotect Password: = "password"Indstil newWB = Workbooks.Add'Juster displayetActiveWindow.Zoom = 80ActiveWindow.DisplayGridlines = Falsk'Kopier + indsæt værdieroldWB.ActivateoldWB.ActiveSheet.Cells.SelectUdvælgelse. KopinyWB.AktivernewWB.ActiveSheet.Cells.SelectSelection.PasteSpecial Paste: = xlPasteValues, Operation: = xlNone, SkipBlanks _: = Falsk, Transponer: = FalskSelection.PasteSpecial Paste: = xlPasteFormats, Operation: = xlNone, _SkipBlanks: = Falsk, Transponer: = FalskSelection.PasteSpecial Paste: = xlPasteValidation, Operation: = xlNone, _SkipBlanks: = Falsk, Transponer: = Falsk'Vælg ny WB, og deaktiver kopieringstilstandnewWB.ActiveSheet.Range ("A10"). VælgApplication.CutCopyMode = Falsk'Gem filennewWB.SaveAs filnavn: = SaveLocation, _FileFormat: = xlOpenXMLWorkbook, CreateBackup: = FalskFilePath = Application.ActiveWorkbook.FullName'Beskyt gamleWBoldWB.ActiveSheet.Protect Password: = "password", DrawingObjects: = True, Contents: = True, Scenarier: = True _, AllowFormattingCells: = True, AllowFormattingColumns: = True, _AllowFormattingRows: = True'E -mailVed fejl Genoptag næsteMed OutMail.to = "[email protected]".CC = "".BCC = "".Subject = Project_Name & ":" & Template_Name & "for review".Body = "Project Name:" & Project_Name & "," & Name & "For review by" & ReviewDate.Attachments.Add (FilePath).Skærm'.Send' Valgfrit til at automatisere afsendelse af e -mail.Afslut medVed fejl GoTo 0Set OutMail = IntetIndstil OutApp = Intet'Afslut makro, gendan skærmopdatering, beregninger osv … endmacro:Application.DisplayAlerts = TrueApplication.enableevents = TrueApplication.ScreenUpdating = TrueApplication.Calculation = xlCalculationAutomaticAfslut Sub |
