Call Command Looks For Sheet & If Not found End Sub

T

TkdKidSnake

Active Member
Joined
Nov 27, 2012
Messages
255
Office Version
  1. 365
Platform
  1. Windows
Hi all,

I am after some help, I use the following code to call a sheet and then produce it as a PDF, then it sets up the email ready to send - this is setup for 200 sheets and rather than make the button call up on active sheets where I have not used ' to negate the call. Is there a way of putting code in to say if sheet not found go to end sub?

Code: 
Sub ScorecardPdf001()

Application.ScreenUpdating = False


Sheets("S1").Select
        
    'Home Location
    'ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
        "C:\Users\Steve\Desktop\Supplier Scorecard\Scorecard PDFs\" & Range("AL1") & Range("AE4").Value, Quality:=xlQualityStandard, IncludeDocProperties:= _
        True, IgnorePrintAreas:=False, OpenAfterPublish:=False
    
    'Work Location
    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
        "\\pel.com\group\Resources\Purchasing\Public\Supplier KPI\Scorecard Bedford - Red Cards - IDs - Protected Stock - OTIF\Scorecard PDFs\" _
        & Range("AL1") & Range("AE4").Value, Quality:=xlQualityStandard, IncludeDocProperties:= _
        True, IgnorePrintAreas:=False, OpenAfterPublish:=False
        


Dim OutApp As Object
    Dim OutMail As Object
    Dim fname As String, sendto As String, sendcc As String, sendbcc As String, sendsubject As String, sendbody As String


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


    '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    ' Check sheet names, paths, cell locations and email text below
    '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    fname = "\\zzz.com\group\Resources\Purchasing\Public\Supplier KPI\Scorecard Bedford - Red Cards - IDs - Protected Stock - OTIF\Scorecard PDFs\" & Range("AL1") & Range("AE4").Value
    
 sendto = Sheets("S1").Range("AE16").Value
    
    sendcc = Sheets("Emails").Range("C397").Value
    
    sendbcc = Sheets("Emails").Range("C399").Value
    
    sendsubject = Sheets("S1").Range("AE4").Value
    
    sendbody = "<H3><B>Dear Supplier,</B></H3>" & _
              "Attached is our latest Scorecard for yourselves which has now been updated to include all<br>" & _
              "the relevant data transactions from the previous month.<br><br>" & _
              "Please review and contact me or any member of the management team here<br>" & _
              "at zzz manufacturing if you would like to discuss further.<br>" & _
              "<br><br><B>Thank you for your continued support.<br></B>"
          
    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=fname, _
    Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False


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




    On Error Resume Next
    With OutMail
        .Display
        '.send
        .To = sendto
        .CC = sendcc
        .BCC = sendbcc
        .Subject = sendsubject
        .HTMLBody = sendbody & "<br>" & .HTMLBody
        .Attachments.Add fname & ".pdf"


    End With
    
    On Error GoTo 0




    Set OutMail = Nothing
    Set OutApp = Nothing




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


Sheets("Data Entry").Select


Application.ScreenUpdating = True


End Sub


The sheets all start from S1 through to S200 and rather than negate the call code I would like to include perhaps an error handler if thats the best way of doing it.

Thanks for any help you can provide.
 

Excel Facts

Easy bullets in Excel
If you have a numeric keypad, press Alt+7 on numeric keypad to type a bullet in Excel.
Sort by date Sort by votes
I hope the following works for you. I made several adjustments.

Code: 
Sub ScorecardPdf001()
  Dim OutApp As Object, OutMail As Object
  Dim fname As String, sendto As String, sendcc As String, sendbcc As String
  Dim sendsubject As String, sendbody As String
  Dim sh As Worksheet, fPath1 As String, fPath2 As String, i As Long
  '
  [COLOR=#0000ff]fPath1 [/COLOR]= "\\pel.com\group\Resources\Purchasing\Public\Supplier KPI\Scorecard Bedford - Red Cards - IDs - Protected Stock - OTIF\Scorecard PDFs\"
  [COLOR=#ff0000]fPath2[/COLOR] = "\\zzz.com\group\Resources\Purchasing\Public\Supplier KPI\Scorecard Bedford - Red Cards - IDs - Protected Stock - OTIF\Scorecard PDFs\"
  Application.ScreenUpdating = False
  Application.EnableEvents = False
  For i = 1 To Sheets.Count
    If Evaluate("ISREF('" & "S" & i & "'!A1)") Then
      Set sh = Sheets("S" & i)
[COLOR=#008000]      fname = sh.Range("AL1") & sh.Range("AE4").Value & ".pdf"[/COLOR]
      'Home Location
        'sh.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
          "C:\Users\Steve\Desktop\Supplier Scorecard\Scorecard PDFs\" & fname, _
          Quality:=xlQualityStandard, IncludeDocProperties:=True, _
          IgnorePrintAreas:=False, OpenAfterPublish:=False
      'Work Location
        sh.ExportAsFixedFormat Type:=xlTypePDF, Filename:=[COLOR=#0000ff]fPath1 [/COLOR]& [COLOR=#008000]fname[/COLOR], _
          Quality:=xlQualityStandard, IncludeDocProperties:=True, _
          IgnorePrintAreas:=False, OpenAfterPublish:=False
        sh.ExportAsFixedFormat Type:=xlTypePDF, Filename:=[COLOR=#ff0000]fPath2[/COLOR] & [COLOR=#008000]fname[/COLOR], _
          Quality:=xlQualityStandard, IncludeDocProperties:=True, _
          IgnorePrintAreas:=False, OpenAfterPublish:=False
      ' Check email text below
      sendto = sh.Range("AE16").Value
      sendcc = Sheets("Emails").Range("C397").Value
      sendbcc = Sheets("Emails").Range("C399").Value
      sendsubject = sh.Range("AE4").Value
      sendbody = "Dear Supplier, " & _
        "Attached is our latest Scorecard for yourselves which has now been updated to include all" & _
        "the relevant data transactions from the previous month." & _
        "Please review and contact me or any member of the management team here" & _
        "at zzz manufacturing if you would like to discuss further." & _
        "Thank you for your continued support."
      Set OutApp = CreateObject("Outlook.Application")
      Set OutMail = OutApp.CreateItem(0)
      On Error Resume Next
      With OutMail
        .To = sendto
        .Cc = sendcc
        .Bcc = sendbcc
        .Subject = sendsubject
        .HTMLBody = sendbody & "" & .HTMLBody
        .Attachments.Add [COLOR=#ff0000]fPath2 [/COLOR]& [COLOR=#008000]fname[/COLOR]
        .Display
        '.send
      End With
      On Error GoTo 0
    End If
  Next
  Set OutMail = Nothing
  Set OutApp = Nothing
  Application.ScreenUpdating = True
  Application.EnableEvents = True
  Sheets("Data Entry").Select
  Application.ScreenUpdating = True
End Sub
 
Upvote 0
Absolutely awesome works a treat many thanks.

DanteAmor said:
I hope the following works for you. I made several adjustments.

Code: 
Sub ScorecardPdf001()
  Dim OutApp As Object, OutMail As Object
  Dim fname As String, sendto As String, sendcc As String, sendbcc As String
  Dim sendsubject As String, sendbody As String
  Dim sh As Worksheet, fPath1 As String, fPath2 As String, i As Long
  '
  [COLOR=#0000ff]fPath1 [/COLOR]= "\\pel.com\group\Resources\Purchasing\Public\Supplier KPI\Scorecard Bedford - Red Cards - IDs - Protected Stock - OTIF\Scorecard PDFs\"
  [COLOR=#ff0000]fPath2[/COLOR] = "\\zzz.com\group\Resources\Purchasing\Public\Supplier KPI\Scorecard Bedford - Red Cards - IDs - Protected Stock - OTIF\Scorecard PDFs\"
  Application.ScreenUpdating = False
  Application.EnableEvents = False
  For i = 1 To Sheets.Count
    If Evaluate("ISREF('" & "S" & i & "'!A1)") Then
      Set sh = Sheets("S" & i)
[COLOR=#008000]      fname = sh.Range("AL1") & sh.Range("AE4").Value & ".pdf"[/COLOR]
      'Home Location
        'sh.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
          "C:\Users\Steve\Desktop\Supplier Scorecard\Scorecard PDFs\" & fname, _
          Quality:=xlQualityStandard, IncludeDocProperties:=True, _
          IgnorePrintAreas:=False, OpenAfterPublish:=False
      'Work Location
        sh.ExportAsFixedFormat Type:=xlTypePDF, Filename:=[COLOR=#0000ff]fPath1 [/COLOR]& [COLOR=#008000]fname[/COLOR], _
          Quality:=xlQualityStandard, IncludeDocProperties:=True, _
          IgnorePrintAreas:=False, OpenAfterPublish:=False
        sh.ExportAsFixedFormat Type:=xlTypePDF, Filename:=[COLOR=#ff0000]fPath2[/COLOR] & [COLOR=#008000]fname[/COLOR], _
          Quality:=xlQualityStandard, IncludeDocProperties:=True, _
          IgnorePrintAreas:=False, OpenAfterPublish:=False
      ' Check email text below
      sendto = sh.Range("AE16").Value
      sendcc = Sheets("Emails").Range("C397").Value
      sendbcc = Sheets("Emails").Range("C399").Value
      sendsubject = sh.Range("AE4").Value
      sendbody = "Dear Supplier, " & _
        "Attached is our latest Scorecard for yourselves which has now been updated to include all" & _
        "the relevant data transactions from the previous month." & _
        "Please review and contact me or any member of the management team here" & _
        "at zzz manufacturing if you would like to discuss further." & _
        "Thank you for your continued support."
      Set OutApp = CreateObject("Outlook.Application")
      Set OutMail = OutApp.CreateItem(0)
      On Error Resume Next
      With OutMail
        .To = sendto
        .Cc = sendcc
        .Bcc = sendbcc
        .Subject = sendsubject
        .HTMLBody = sendbody & "" & .HTMLBody
        .Attachments.Add [COLOR=#ff0000]fPath2 [/COLOR]& [COLOR=#008000]fname[/COLOR]
        .Display
        '.send
      End With
      On Error GoTo 0
    End If
  Next
  Set OutMail = Nothing
  Set OutApp = Nothing
  Application.ScreenUpdating = True
  Application.EnableEvents = True
  Sheets("Data Entry").Select
  Application.ScreenUpdating = True
End Sub
Click to expand...
 
Upvote 0
Hi Dante Amor,

Many thanks for your help with this, everything is working apart from it no longer adds my default signature when setting up the emails - would you know why?

Code: 
Sub ScorecardPdfEmail()



  Dim OutApp As Object, OutMail As Object
  Dim fname As String, sendto As String, sendcc As String, sendbcc As String
  Dim sendsubject As String, sendbody As String
  Dim sh As Worksheet, fPath As String, i As Long
  '
  fPath = "\\pel.com\group\Resources\Purchasing\Public\Supplier KPI\Scorecard Bedford - Red Cards - IDs - Protected Stock - OTIF\Scorecard PDFs\"


  Application.ScreenUpdating = False
  Application.EnableEvents = False
  
  For i = 1 To Sheets.Count
    If Evaluate("ISREF('" & "S" & i & "'!A1)") Then
      Set sh = Sheets("S" & i)
      fname = sh.Range("AL1") & sh.Range("AE4").Value & ".pdf"


      'Work Location
        sh.ExportAsFixedFormat Type:=xlTypePDF, Filename:=fPath & fname, _
          Quality:=xlQualityStandard, IncludeDocProperties:=True, _
          IgnorePrintAreas:=False, OpenAfterPublish:=False


      'Check email text below
      sendto = sh.Range("AE16").Value
      sendcc = Sheets("Emails").Range("D403").Value
      sendbcc = Sheets("Emails").Range("D405").Value
      
      sendsubject = sh.Range("AE4").Value
      
      sendbody = "<H3><B>Dear Supplier,</B></H3>" & _
              "Attached is our latest Scorecard for yourselves which has now been updated to include all<br>" & _
              "the relevant data transactions from the previous month.<br><br>" & _
              "Please review and contact me or any member of the management team here<br>" & _
              "at JJS Manufacturing if you would like to discuss further.<br>" & _
              "<br><br><B>Thank you for your continued support.<br></B>"
        
      Set OutApp = CreateObject("Outlook.Application")
      Set OutMail = OutApp.CreateItem(0)
      
      On Error Resume Next
      
      With OutMail
        .To = sendto
        .Cc = sendcc
        .Bcc = sendbcc
        .Subject = sendsubject
        .HTMLBody = sendbody & "<br>" & .HTMLBody
        .Attachments.Add fPath & fname
        .Display
        '.send
      End With
      
      On Error GoTo 0
      
    End If
  Next
  
  Set OutMail = Nothing
  Set OutApp = Nothing
  
  Application.ScreenUpdating = True
  Application.EnableEvents = True
  
  Sheets("Data Entry").Select
  
End Sub

I have also noticed that when I add the part of the code in here that it changes so I'll attempt to put it below with some extra spaces around the less than br greater than to see how it displays apologies if it still isn't clear:

.HTMLBody = sendbody & " < br > " & .HTMLBody


Thanks in advance
 
Upvote 0
TkdKidSnake said:
I have also noticed that when I add the part of the code in here that it changes so I'll attempt to put it below with some extra spaces around the less than br greater than to see how it displays apologies if it still isn't clear:

.HTMLBody = sendbody & " < br > " & .HTMLBody


Thanks in advance
Click to expand...


In theory that line is to send the signature, I don't know what the fault is.
 
Upvote 0
You must log in or register to reply here.

Similar threads

K
  • Question Question
Excel Macro to Save to .pdf not working
Replies
9
Views
1K
kpost
K
S
  • Solved
Sheets selection based on tab color
Replies
2
Views
85
SoerenB
S
S
  • Solved
If Dir(FullName) <> vbNull String Then Giving Runtime Error 52
Replies
5
Views
310
StedDOOM
S
N
  • Question Question
Emailing from Excel and automatically attaching pdf
Replies
1
Views
366
dermie_72
D
Y
  • Solved
Create email with all currently selected sheets attached as individual pdf files
Replies
2
Views
376
Yamezz
Y

Forum statistics

Threads
1,224,813
Messages
6,181,114
Members
453,021
Latest member
Justyna P

Share this page

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