Call Command Looks For Sheet & If Not found End Sub

TkdKidSnake

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

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
9,682
Office Version
2007
Platform
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
231
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
231
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
9,682
Office Version
2007
Platform
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.
 

Forum statistics

Threads
1,085,538
Messages
5,384,311
Members
401,887
Latest member
Somesh

Some videos you may like

This Week's Hot Topics

Top