Macro

Joesif

Board Regular
Joined
Feb 23, 2010
Messages
65
Hi All

I'm after a macro that Copies a single sheet from a workbook onto a new workbook on its own to reduce the size of the file. And start to send on outlook. But also I need the macro to check 3 cells, if they are not filled in then the macro will fail

Thanks
Joe
 

Excel Facts

Bring active cell back into view
Start at A1 and select to A9999 while writing a formula, you can't see A1 anymore. Press Ctrl+Backspace to bring active cell into view.
Here is something to get you started.

First check your three cells.
Then Copy Worksheet and save.
Then Emal - this is not my code - NB Edit for your own needs.

Code:
[COLOR=darkblue]Sub[/COLOR] test()
   [COLOR=darkblue]Dim[/COLOR] wb [COLOR=darkblue]As[/COLOR] Workbook
   [COLOR=darkblue]Dim[/COLOR] sFilename [COLOR=darkblue]As[/COLOR] [COLOR=darkblue]String[/COLOR]
   
   [COLOR=green]'test three cells SHEET1[/COLOR]
   [COLOR=darkblue]With[/COLOR] Sheets("Sheet1")
      [COLOR=darkblue]If[/COLOR] .Range("A1").Value <> "x" [COLOR=darkblue]Then[/COLOR]
         [COLOR=green]'MsgBox "A1 Failed"[/COLOR]
         [COLOR=darkblue]Exit[/COLOR] [COLOR=darkblue]Sub[/COLOR]
      [COLOR=darkblue]ElseIf[/COLOR] .Range("A2").Value <> "x" [COLOR=darkblue]Then[/COLOR]
         [COLOR=green]'MsgBox "A2 Failed"[/COLOR]
         [COLOR=darkblue]Exit[/COLOR] [COLOR=darkblue]Sub[/COLOR]
      [COLOR=darkblue]ElseIf[/COLOR] .Range("A3").Value <> "x" [COLOR=darkblue]Then[/COLOR]
         [COLOR=green]'MsgBox "A3 Failed"[/COLOR]
         [COLOR=darkblue]Exit[/COLOR] [COLOR=darkblue]Sub[/COLOR]
      [COLOR=darkblue]End[/COLOR] [COLOR=darkblue]If[/COLOR]
   [COLOR=darkblue]End[/COLOR] [COLOR=darkblue]With[/COLOR]
   
   [COLOR=green]'copy sheet as new workbook[/COLOR]
   Sheets("Sheet1").Copy
   [COLOR=darkblue]Set[/COLOR] wb = ActiveWorkbook
   sFilename = ThisWorkbook.Path & "Bertie.xlsx"
   [COLOR=darkblue]With[/COLOR] wb
      .SaveAs Filename:=sFilename
      .Close SaveChanges:=[COLOR=darkblue]True[/COLOR]
   [COLOR=darkblue]End[/COLOR] [COLOR=darkblue]With[/COLOR]
   [COLOR=darkblue]Set[/COLOR] wb = [COLOR=darkblue]Nothing[/COLOR]
   
   [COLOR=green]'send to Outloook[/COLOR]
   Mail_Workbook_1 sFilename
         
  
[COLOR=darkblue]End[/COLOR] [COLOR=darkblue]Sub[/COLOR]


Sub Mail_Workbook_1([COLOR=darkblue]ByVal[/COLOR] sFilename [COLOR=darkblue]As[/COLOR] [COLOR=darkblue]String[/COLOR])
[COLOR=green]'Source: "http://msdn.microsoft.com/en-us/library/ff458119(office.11).aspx"[/COLOR]


[COLOR=green]' Works in Excel 2000, Excel 2002, Excel 2003, Excel 2007, Excel 2010, Outlook 2000, Outlook 2002, Outlook 2003, Outlook 2007, Outlook 2010.[/COLOR]
[COLOR=green]' This example sends the last saved version of the Activeworkbook object .[/COLOR]
    [COLOR=darkblue]Dim[/COLOR] OutApp [COLOR=darkblue]As[/COLOR] [COLOR=darkblue]Object[/COLOR]
    [COLOR=darkblue]Dim[/COLOR] OutMail [COLOR=darkblue]As[/COLOR] [COLOR=darkblue]Object[/COLOR]


    [COLOR=darkblue]Set[/COLOR] OutApp = CreateObject("Outlook.Application")
    [COLOR=darkblue]Set[/COLOR] OutMail = OutApp.CreateItem(0)


    [COLOR=darkblue]On[/COLOR] [COLOR=darkblue]Error[/COLOR] [COLOR=darkblue]Resume[/COLOR] [COLOR=darkblue]Next[/COLOR]
   
   [COLOR=green]' Change the mail address and subject in the macro before you run it.[/COLOR]
    [COLOR=darkblue]With[/COLOR] OutMail
        .To = "ron@debruin.nl"
        .CC = ""
        .BCC = ""
        .[COLOR=darkblue]Sub[/COLOR]ject = "This is the Subject line"
        .Body = "Hello World!"
        .Attachments.Add sFilename
        
        [COLOR=green]' You can add other files by uncommenting the following line.[/COLOR]
        [COLOR=green]'.Attachments.Add ("C:\test.txt")[/COLOR]
        [COLOR=green]' In place of the following statement, you can use ".Display" to[/COLOR]
        [COLOR=green]' display the mail.[/COLOR]
        .Send
        
    [COLOR=darkblue]End[/COLOR] [COLOR=darkblue]With[/COLOR]
    [COLOR=darkblue]On[/COLOR] [COLOR=darkblue]Error[/COLOR] [COLOR=darkblue]GoTo[/COLOR] 0


    [COLOR=darkblue]Set[/COLOR] OutMail = [COLOR=darkblue]Nothing[/COLOR]
    [COLOR=darkblue]Set[/COLOR] OutApp = [COLOR=darkblue]Nothing[/COLOR]
End Sub

Hope it helps,
Bertie
 
Upvote 0
Thanks Bertie this is PERFECT! :)

One more thing I am looking to do though, when the file sends I want the contents of cell A4 to be on the name of the file thats sent so sFilename = ThisWorkbook.Path & "Bertie.xlsx"
sFilename = CONTENTS OF CELL A4 HERE & "Bertie.xlsx"
is this possible please?
 
Upvote 0
Amend this line:
Code:
sFilename = ThisWorkbook.Path & "Bertie.xlsx"

To: (Edit for correct sheet name)

Code:
sFilename = ThisWorkbook.Path & [COLOR=#ff0000]Sheets("Sheet1").Range("A4").value[/COLOR] & "-Bertie.xlsx"

NB - If A4 contains any special characters, which cannot be used in file names, the code will crash when assigning the name to the saved file.
 
Upvote 0
Hi Bertie

The code was working perfect and again thanks for all your help. However now the macro is sending a blank email with nothing attached! I've remade the macro from your code but it's still sending a blank email. Have I missed something?

Code:
Sub Send()
   Dim wb As Workbook
   Dim sFilename As String
   
   'test three cells ORDER SUMMARY
   With Sheets("ORDER SUMMARY")
      If .Range("J73").Value <> "YES" Then
         MsgBox "J73 Failed You have not agreed to - I HAVE COMPLETED THE CHECKLIST"
         Exit Sub
      ElseIf .Range("J74").Value <> "YES" Then
         MsgBox "J74 Failed You have not agreed to - I HAVE READ AND UNDERSTAND THE TERMS AND CONDITIONS"
         Exit Sub
      ElseIf .Range("J75").Value <> "YES" Then
         MsgBox "J75 Failed You have not agreed to - I HAVE STATED IF THE PRODUCTS ARE FOR THE SAME ROOM"
         Exit Sub
      End If
   End With
   
   'copy sheet as new workbook
   Sheets("ORDER SUMMARY").Copy
   Set wb = ActiveWorkbook
   sFilename = "MTO Order Form.xlsx"
   With wb
      .Close SaveChanges:=False
   End With
   Set wb = Nothing
   
   'send to Outloook
   Mail_Workbook_1 sFilename
         
  
End Sub

Sub Mail_Workbook_1(ByVal sFilename As String)
    Dim OutApp As Object
    Dim OutMail As Object

    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)

    On Error Resume Next
   
   
    With OutMail
        .To = [EMAIL="joescutt@belfield.com"]joescutt@belfield.com[/EMAIL]
        .CC = ""
        .BCC = ""
        .Subject = "MTO ORDER FORM"
        .Body = ""
        .Attachments.Add sFilename
        
       
        ' In place of the following statement, you can use ".Display" to
        ' display the mail.
        .Send
        
    End With
    On Error GoTo 0

    Set OutMail = Nothing
    Set OutApp = Nothing
End Sub

Thanks
Joe
 
Upvote 0
At first glance it looks like you haven't saved the file in the Send() procedure.

Try this:

Code:
[COLOR=green]'copy sheet as new workbook[/COLOR]
   Sheets("ORDER SUMMARY").Copy
   [COLOR=darkblue]Set[/COLOR] wb = ActiveWorkbook
   
   sFilename = "[COLOR=#ff0000]C:\temp\[/COLOR]MTO Order Form.xlsx"
   wb.Close SaveChanges:=[COLOR=#ff0000]True[/COLOR], Filename:=sFilename
   
   [COLOR=darkblue]Set[/COLOR] wb = [COLOR=darkblue]Nothing[/COLOR]

Then when you send sFilename to the Mail_WOrkbook_1() procedure it will find the file to attach.
 
Upvote 0
Code:
Sub Mail_ActiveSheet()
' Works in Excel 2000, Excel 2002, Excel 2003, Excel 2007, Excel 2010, Outlook 2000, Outlook 2002, Outlook 2003, Outlook 2007, Outlook 2010
    Dim FileExtStr As String
    Dim FileFormatNum As Long
    Dim Sourcewb As Workbook
    Dim Destwb As Workbook
    Dim TempFilePath As String
    Dim TempFileName As String
    Dim OutApp As Object
    Dim OutMail As Object
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With
   With Sheets("ORDER SUMMARY")
      If .Range("J73").Value <> "YES" Then
         MsgBox "J73 Failed You have not agreed to - I HAVE COMPLETED THE CHECKLIST"
         Exit Sub
      ElseIf .Range("J74").Value <> "YES" Then
         MsgBox "J74 Failed You have not agreed to - I HAVE READ AND UNDERSTAND THE TERMS AND CONDITIONS"
         Exit Sub
      ElseIf .Range("J75").Value <> "YES" Then
         MsgBox "J75 Failed You have not agreed to - I HAVE STATED IF THE PRODUCTS ARE FOR THE SAME ROOM"
         Exit Sub
      End If
   End With
    Set Sourcewb = ActiveWorkbook
    ' Next, copy the sheet to a new workbook.
    ' You can also use the following line, instead of using the ActiveSheet object,
   ' if you know the name of the sheet you want to mail :
    ' Sheets("Sheet5").Copy
    ActiveSheet.Copy
    Set Destwb = ActiveWorkbook
 ' Determine the Excel version, and file extension and format.
    With Destwb
        If Val(Application.Version) < 12 Then
            ' For Excel 2000-2003
            FileExtStr = ".xlsx": FileFormatNum = -4143
             Else
            ' For Excel 2007-2010, exit the subroutine if you answer
            ' NO in the security dialog that is displayed when you copy
            ' a sheet from an .xlsm file with macros disabled.
            If Sourcewb.Name = .Name Then
                With Application
                    .ScreenUpdating = True
                    .EnableEvents = True
                End With
                MsgBox "You answered NO in the security dialog."
                Exit Sub
            Else
                Select Case Sourcewb.FileFormat
                Case 51: FileExtStr = ".xlsx": FileFormatNum = 51
                Case 52:
                    If .HasVBProject Then
                        FileExtStr = ".xlsm": FileFormatNum = 52
                    Else
                        FileExtStr = ".xlsx": FileFormatNum = 51
                    End If
                Case 56: FileExtStr = ".xls": FileFormatNum = 56
                Case Else: FileExtStr = ".xlsb": FileFormatNum = 50
                End Select
            End If
        End If
    End With
    
    ' You can use the following statements to change all cells in the
   ' worksheet to values.
    '    With Destwb.Sheets(1).UsedRange
    '        .Cells.Copy
    '        .Cells.PasteSpecial xlPasteValues
    '        .Cells(1).Select
    '    End With
    '    Application.CutCopyMode = False
    ' Save the new workbook, mail, and then delete it.
    TempFilePath = Environ$("temp") & "\"
    TempFileName = "MTO ORDER FORM"
    Set OutApp = CreateObject("Outlook.Application")
    
    Set OutMail = OutApp.CreateItem(0)
    With Destwb
        .SaveAs TempFilePath & TempFileName & FileExtStr, _
                FileFormat:=FileFormatNum
        On Error Resume Next
       ' Change the mail address and subject in the macro before
       ' running the procedure.
        With OutMail
            .To = "[EMAIL="samantha.renshaw@belfieldfurnishings.com"]samantha.renshaw@belfieldfurnishings.com[/EMAIL]"
            .CC = ""
            .BCC = ""
            .Subject = "MTO ORDER FORM"
            .Body = ""
            .Attachments.Add Destwb.FullName
            ' You can add other files by uncommenting the following statement.
            '.Attachments.Add ("C:\test.txt")
            ' In place of the following statement, you can use ".Display" to
            ' display the mail.
            .Send
        End With
        On Error GoTo 0
        .Close SaveChanges:=False
    End With
    ' Delete the file after sending.
    Kill TempFilePath & TempFileName & FileExtStr
    Set OutMail = Nothing
    Set OutApp = Nothing
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
End Sub

Thanks Bertie, I went here from your previous post and used the other code. Using VBA in Excel to Send Workbooks and Ranges Through E-Mail with Outlook (Part 1 of 2)
Works fine :)
Thanks for all your help
 
Upvote 0

Forum statistics

Threads
1,213,557
Messages
6,114,291
Members
448,564
Latest member
ED38

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