Call Command Looks For Sheet & If Not found End Sub

T

TkdKidSnake

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

Whats the difference between CONCAT and CONCATENATE?
The newer CONCAT function can reference a range of cells. =CONCATENATE(A1,A2,A3,A4,A5) becomes =CONCAT(A1:A5)
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
Excel Macro to Save to .pdf not working
Replies
9
Views
216
kpost
K
D
  • Solved
VBA save as PDF overwrite warning code
Replies
4
Views
679
drefiek2
D
L
  • Question
email current sheet as macro enabled workbook
Replies
0
Views
239
lizemi
L
D
  • Solved
VBA SaveAsPDF into current year/month shared OneDrive folder
Replies
2
Views
989
drefiek2
D
C
  • Solved
PDF specific sheets into new created folder in Workbook location
Replies
2
Views
464
camerong
C

Forum statistics

Threads
1,214,377
Messages
6,119,183
Members
448,872
Latest member
lcaw

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