Questo codice salva un foglio di lavoro come nuova cartella di lavoro e crea un'e-mail in Outlook con la nuova cartella di lavoro allegata. È molto utile se disponi di un modello di foglio di calcolo standardizzato utilizzato nella tua organizzazione.
Per un esempio più semplice, guarda Come inviare e-mail da Excel
Salva foglio di lavoro come nuova cartella di lavoro e allega a e-mail
| 123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108 | Sottoposta_cartella di lavoro()Application.DisplayAlerts = FalseApplication.enableevents = FalseApplication.ScreenUpdating = FalseApplication.Calculation = xlCalculationManualDim OutApp come oggettoDim OutMail come oggettoDim FilePath As StringDim Project_Name As StringDim Template_Name As StringDim ReviewDate As StringDim SaveLocation As StringDim Path As StringNome fioco come stringa'Crea variabili inizialiImposta OutApp = CreateObject("Outlook.Application")Imposta OutMail = OutApp.CreateItem(0)Nome_Progetto = Fogli("foglio1").Intervallo("NomeProgetto").ValoreTemplate_Name = ActiveSheet.Name"Richiedi input utilizzato nell'e-mail"ReviewDate = InputBox (Prompt: = "Fornisci la data entro la quale desideri che la presentazione venga esaminata.", Title: = "Enter Date", Default: = "MM/DD/YYYY")Se ReviewDate = "Enter Date" o ReviewDate = vbNullString Then GoTo endmacro"Salva foglio di lavoro come cartella di lavoro"Path = ActiveWorkbook.PathNome = Taglia(Mid(ActiveSheet.Nome, 4, 99))Imposta ws = ActiveSheetImposta oldWB = ThisWorkbookSaveLocation = InputBox(Prompt:="Scegli nome file e posizione", Title:="Salva con nome", Predefinito:=CreateObject("WScript.Shell").SpecialFolders("Desktop") & "/" & Name & ". xlsx")If Dir(SaveLocation) "" ThenMsgBox ("Esiste già un file con quel nome. Scegli un nuovo nome o elimina il file esistente.")SaveLocation = InputBox(Prompt:="Scegli nome file e posizione", Title:="Salva con nome", Predefinito:=CreateObject("WScript.Shell").SpecialFolders("Desktop") & "/" & Name & ". xlsx")Finisci seSe SaveLocation = vbNullString Then GoTo endmacro'sproteggi foglio se necessarioActiveSheet.Unprotect Password:="password"Imposta newWB = Cartelle di lavoro.Aggiungi"Regola visualizzazione"ActiveWindow.Zoom = 80ActiveWindow.DisplayGridlines = False"Copia + Incolla valori"oldWB.AttivaoldWB.ActiveSheet.Cells.SelectSelezione.CopianewWB.AttivanewWB.ActiveSheet.Cells.SelectSelection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _:=Falso, Trasposizione:=FalsoSelection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _SkipBlanks:=False, Transpose:=FalseSelection.PasteSpecial Paste:=xlPasteValidation, Operation:=xlNone, _SkipBlanks:=False, Transpose:=False'Seleziona nuovo bilanciamento del bianco e disattiva la modalità cutcopynewWB.ActiveSheet.Range("A10").SelezionaApplication.CutCopyMode = False'Salvare il filenewWB.SaveAs Filename:=SaveLocation, _FileFormat:=xlOpenXMLWorkbook, CreateBackup:=FalseFilePath = Application.ActiveWorkbook.FullName"Riproteggi oldWB"oldWB.ActiveSheet.Protect Password:="password", DrawingObjects:=True, Contents:=True, Scenari:=True _, AllowFormattingCells:=True, AllowFormattingColumns:=True, _AllowFormattingRows:=Vero'E-mailIn caso di errore Riprendi AvantiCon OutMail.to = "[email protected]".CC = "".BCC = "".Subject = Project_Name & ": " & Template_Name & " per revisione".Body = "Nome progetto: " & Project_Name & ", " & Name & " Per revisione da " & ReviewDate.Attachments.Add (FilePath).Schermo' .Invia 'Facoltativo per automatizzare l'invio di email.Termina conIn caso di errore Vai a 0Imposta OutMail = NienteImposta OutApp = Niente'Termina macro, ripristina aggiornamento schermo, calcoli, ecc… endmacro:Application.DisplayAlerts = TrueApplication.enableevents = TrueApplication.ScreenUpdating = TrueApplicazione.Calcolo = xlCalcoloAutomaticoFine sottotitolo |
