VBA to save and email workbook

MissingInAction

Board Regular
Joined
Sep 20, 2019
Messages
85
Office Version
  1. 365
Platform
  1. Windows
Hi everyone

I created a workbook where managers must review the employee access to our systems. All the data is on my data sheet (User Access Info). Every manager has a sheet with his/her employee's system access information ("sheet 1" in this example). "Sheet 1" makes use of a pivot table so that the manager only see his/her own employees and not others.
I only added the code for one sheet (as an example), since the code is the same for all sheets.

I created a macro that must do the following:
Remove the sensitive personnel information from each sheet
Remove formulas/pivot tables by using the paste as values functions
Remove remove my "user access info" sheet which is the data source for the now deleted pivot tables
Save the changes made
Email the entire workbook to management.

The problem is that it does not save the workbook. Even though the changes mentioned above and the "ActiveWorkbook.Save" code is listed before the "send email" code, it emails the workbook without any changes. I know the code works, since I can see the changes being made on my screen while its flashing between the sheets. The three segments of code works fine on their own (namely removing the above mentioned data, saving and emailing), but when put into one macro, it does not work.
I found the email code online and it worked in other Excel files where I had to send emails.

Here is the code I'm using:
VBA Code:
Sub Send_Form()
    Sheets("Sheet1").Select
    Cells.Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("A3:A70").Select
    Application.CutCopyMode = False
    Selection.Delete Shift:=xlToLeft
    Cells.Select
    With Selection.Interior
        .Pattern = xlNone
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
    Cells.EntireColumn.AutoFit
    Range("A1").Select
'
    Sheets("User Access Info").Select
    ActiveWindow.SelectedSheets.Delete
    Sheets("Selection").Select
    Range("A1").Select
'
    ActiveWorkbook.Save
'Email the workbook
    Dim OutMail As Object
    Dim OutApp As Object
    Dim OutMsg As String

    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With

    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
    
    OutMsg = "Sample Line 1<br />" & _
             "<br />" & _
             "Sample Line 2"
    On Error Resume Next
    With OutMail
        .To = "<list of email addresses>"
        .CC = ""
        .BCC = ""
        .Subject = "<Subject>"
        .HTMLBody = OutMsg
        .Attachments.Add ActiveWorkbook.FullName
        'You can add other files also like this
        '.Attachments.Add ("C:\test.txt")
        .Send   'or use .Display
    End With
    On Error GoTo 0

    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With

    Set OutMail = Nothing
    Set OutApp = Nothing
    MsgBox "Email Sent"
End Sub
Function RangetoHTML(rng As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2016
    Dim fso As Object
    Dim ts As Object
    Dim TempFile As String
    Dim TempWB As Workbook

    TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"

    'Copy the range and create a new workbook to past the data in
    rng.Copy
    Set TempWB = Workbooks.Add(1)
    With TempWB.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial xlPasteValues, , False, False
        .Cells(1).PasteSpecial xlPasteFormats, , False, False
        .Cells(1).Select
        Application.CutCopyMode = False
        On Error Resume Next
        .DrawingObjects.Visible = True
        .DrawingObjects.Delete
        On Error GoTo 0
    End With

    'Publish the sheet to a htm file
    With TempWB.PublishObjects.Add( _
         SourceType:=xlSourceRange, _
         Filename:=TempFile, _
         Sheet:=TempWB.Sheets(1).Name, _
         Source:=TempWB.Sheets(1).UsedRange.Address, _
         HtmlType:=xlHtmlStatic)
        .Publish (True)
    End With

    'Read all data from the htm file into RangetoHTML
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
    RangetoHTML = ts.readall
    ts.Close
    RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
                          "align=left x:publishsource=")

    'Close TempWB
    TempWB.Close savechanges:=False

    'Delete the htm file we used in this function
    Kill TempFile

    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function

Thank you in advance.
 
So it did make a difference. I have no idea how or why though, but my file is now working as intended. Now I just to find a place to hide the button haha (or run the macro directly from the macro screen).
Thank you for the help Logit.
 
Upvote 0

Excel Facts

Copy formula down without changing references
If you have =SUM(F2:F49) in F50; type Alt+' in F51 to copy =SUM(F2:F49) to F51, leaving the formula in edit mode. Change SUM to COUNT.
.
You can add a line of code that deletes the button, after the sheet is deleted. No need to hide it.

Glad you have a working project !
 
Upvote 0
Tried it and the program emailed the unsaved file again. Seems like it does not like deleting itself.
 
Upvote 0
The button will just be a link to run the macro, so that shouldn't technically make any difference.
 
Upvote 0
Why do you need a button? Can you not just use a shortcut? so Ctrl + u for instance to run the code.
 
Upvote 0
I'm use to using buttons, but I'll have a go at the shortcut keys. Thank you for the tip.
 
Upvote 0

Forum statistics

Threads
1,214,599
Messages
6,120,449
Members
448,966
Latest member
DannyC96

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top