VBA Save Worksheets as values and draft emails

[willastrowalker]

there seem to be lots of codes for this out there and I'm really close to getting it figured out.. I have a workbook that has 26 sheets, I want to create a macro that saves all sheets as hardcodes (completed) and creates a draft email in outlook with each sheet as an attachment.

Created a loop to save all sheets as hardcodes, so that works fine, just need help with what I think is a minor tweak to create individual emails.

Everything works, but the attachments are all placed in the same email, and not in separate email drafts.. So I want 26 drafts with one attachment, not one draft with 26 attachments.

Sub Saveandemail()


    Application.DisplayAlerts = False
    
Dim sname As String
    Dim wsht As Worksheet
    Dim wbnew As Workbook
    Dim todaysdate As String
    Dim wkshtname As String
    Dim OutApp As Object
    Dim Outmail As Object
    Dim Emailaddress as string
            
    Set OutApp = CreateObject("Outlook.Application")
    Set Outmail = OutApp.CreateItem(0)
        
    todaysdate = Format(Now, "MM-DD-YY")
    For Each wsht In ActiveWorkbook.Sheets
        
        wkstname = ActiveSheet.name
        wsht.Copy
        With ActiveSheet.UsedRange
            .Value = .Value
        End With
        Set wbnew = ActiveWorkbook
        sname = Range("g60").Value
        emailaddress = Range("g61").value
    
        With wbnew
            .SaveAs "C:\filepath\" & wsht.name & "_" & todaysdate & ".xlsx"
            With Outmail
                .to = emailaddress
                .CC = ""
                .BCC = ""
                .Subject = "emailing" & wkshtname
                .Body = "Hi there"
                .Attachments.Add wbnew.FullName
                .Save
            End With
       
                 
        wbnew.Close True
        
        End With
    
    Next wsht
        
    Application.DisplayAlerts = True
    
End Sub

 

[dchaney]

Here, try this, changes marked in red

Sub Saveandemail()

[B][COLOR=#ff0000]With Application[/COLOR][/B]
[B][COLOR=#ff0000]    .ScreenUpdating = False[/COLOR][/B]
[B][COLOR=#ff0000]    .DisplayAlerts = False[/COLOR][/B]
[B][COLOR=#ff0000]End With[/COLOR][/B]
    
Dim sname As String
    Dim wsht As Worksheet
    Dim wbnew As Workbook
    Dim todaysdate As String
    Dim wkshtname As String
    Dim OutApp As Object
    Dim Outmail As Object
    Dim Emailaddress As String
            
    Set OutApp = CreateObject("Outlook.Application")
    Set Outmail = OutApp.CreateItem(0)
    
    todaysdate = Format(Now, "MM-DD-YY")
    For Each wsht In ActiveWorkbook.Sheets
        
        wkstname = ActiveSheet.Name
        wsht.Copy
        With ActiveSheet.UsedRange
            .Value = .Value
        End With
        Set wbnew = ActiveWorkbook
        sname = Range("g60").Value
        Emailaddress = Range("g61").Value
    
        With wbnew
            .SaveAs "C:\filepath\" & wsht.name & "_" & todaysdate & ".xlsx"
            With Outmail
[B][COLOR=#ff0000]                .Display[/COLOR][/B]
                .To = Emailaddress
                .CC = ""
                .BCC = ""
                .Subject = "emailing" & wkshtname
                .Body = "Hi there"
                .Attachments.Add wbnew.FullName
                .Save
[B][COLOR=#ff0000]                .Close (xlSave)[/COLOR][/B]
            End With
         
        wbnew.Close True
        
        End With
    
    Next wsht
        
[B][COLOR=#ff0000]With Application[/COLOR][/B]
[B][COLOR=#ff0000]    .ScreenUpdating = True[/COLOR][/B]
[B][COLOR=#ff0000]    .DisplayAlerts = True[/COLOR][/B]
[B][COLOR=#ff0000]End With[/COLOR][/B]
    
End Sub