Call Command Looks For Sheet & If Not found End Sub

TkdKidSnake

Board Regular
Joined
Nov 27, 2012
Messages
238
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.
 

Some videos you may like

Excel Facts

Why does 9 mean SUM in SUBTOTAL?
It is because Sum is the 9th alphabetically in Average, Count, CountA, Max, Min, Product, StDev.S, StDev.P, Sum, VAR.S, VAR.P.

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
12,594
Office Version
  1. 2007
Platform
  1. Windows
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
 

TkdKidSnake

Board Regular
Joined
Nov 27, 2012
Messages
238
Absolutely awesome works a treat many thanks.

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
 

TkdKidSnake

Board Regular
Joined
Nov 27, 2012
Messages
238
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
 

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
12,594
Office Version
  1. 2007
Platform
  1. Windows
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


In theory that line is to send the signature, I don't know what the fault is.
 

Watch MrExcel Video

Forum statistics

Threads
1,122,957
Messages
5,599,051
Members
414,281
Latest member
Engjamal2021

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
Top