Compile Error: Expected End With??

[inkbird1]

Hi all, my email code is not working, can you kindly review and see why I am getting this compile error?

Sub Saveaspdfandsend()
Dim xSht As Worksheet
Dim xFileDlg As FileDialog
Dim xFolder As String
Dim xYesorNo As Integer
Dim xOutlookObj As Object
Dim xEmailObj As Object
Dim xUsedRng As Range
Dim Cell As Range

MsgBox "Save the file to the desktop and ensure to check PDF contents before sending. Note this will send the previous day's Executive Handover"

Set xSht = ActiveSheet
Set xFileDlg = Application.FileDialog(msoFileDialogFolderPicker)

If xFileDlg.Show = True Then
   xFolder = xFileDlg.SelectedItems(1)
Else
   MsgBox "You must specify a folder to save the PDF into." & vbCrLf & vbCrLf & "Press OK to exit .", vbCritical, "Must Specify Destination Folder"
   Exit Sub
End If
xFolder = xFolder + "\" + xSht.Name + "Test"

'Check if file already exist
If Len(Dir(xFolder)) > 0 Then
    xYesorNo = MsgBox(xFolder & " already exists." & vbCrLf & vbCrLf & "Do you want to overwrite it?", _
                      vbYesNo + vbQuestion, "File Exists")
    On Error Resume Next
    If xYesorNo = vbYes Then
        Kill xFolder
    Else
        MsgBox "if you don't overwrite the existing PDF, I can't continue." _
                    & vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Exiting "
        Exit Sub
    End If
    If Err.Number <> 0 Then
        MsgBox "Unable to delete existing file.  Please make sure the file is not open or write protected." _
                    & vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Unable to Delete File"
        Exit Sub
    End If

Set xUsedRng = xSht.UsedRange
If Application.WorksheetFunction.CountA(xUsedRng.Cells) <> 0 Then
    'Save as PDF file
    xSht.ExportAsFixedFormat Type:=xlTypePDF, Filename:=xFolder, Quality:=xlQualityStandard

    'Create Outlook email send list
    For Each Cell In Worksheets("Lists").Range("W2:W50").Cells.SpecialCells(xlCellTypeConstants)
 
    Set xOutlookObj = CreateObject("Outlook.Application")
    Set xEmailObj = xOutlookObj.CreateItem(0)
    With xEmailObj
        .Display
        .To = Cell.Value
        .CC = ""
        .Subject = "Test " & Format(Date - 1, "dd/mm/yyyy")
        .Attachments.Add xFolder
        If DisplayEmail = False Then
            '.Send
     
  MsgBox "The active worksheet cannot be blank"
  Exit Sub
 
End If


End Sub

 

[Fazza]

from a quick look, there may be an End If missing

 

[Peter_SSs]

In fact, you have a number of incomplete blocks of code. The ones I can see are:

You have 6 'If' blocks started but only 4 'End If' statements.
You have 1 'For Each Cell' block started but 0 'Next Cell' statements
You have 1 'With' block started but 0 'End with' statements

 

[inkbird1]

thanks for your replies - I am farily new to VBA, is somebody kindly able to assist me correcting this code please?

 

[Peter_SSs]

is somebody kindly able to assist me correcting this code please?

Without knowing what your data is (eg 'Lists' W2:W50), your folder/file structure etc, what is likely to be chosen in the file dialog or exactly what the code is supposed to do, that is a bit tricky?

Did you write the code yourself or get it from elsewhere?

 

[inkbird1]

Without knowing what your data is (eg 'Lists' W2:W50), your folder/file structure etc, what is likely to be chosen in the file dialog or exactly what the code is supposed to do, that is a bit tricky?

Did you write the code yourself or get it from elsewhere?

Thanks Peter, i get it from elsewhere.

The following code is what I orginally had before the errors. All i am trying to achieve is when the email and file attachments populate it pulls the email addresses in the W range of the workseet and populates them in the TO: field in Outlook

Sub Saveaspdfandsend()
Dim xSht As Worksheet
Dim xFileDlg As FileDialog
Dim xFolder As String
Dim xYesorNo As Integer
Dim xOutlookObj As Object
Dim xEmailObj As Object
Dim xUsedRng As Range

MsgBox "Save the file to the desktop and ensure to check PDF contents before sending. Note this will send the previous day's Executive Handover"

Set xSht = ActiveSheet
Set xFileDlg = Application.FileDialog(msoFileDialogFolderPicker)

If xFileDlg.Show = True Then
   xFolder = xFileDlg.SelectedItems(1)
Else
   MsgBox "You must specify a folder to save the PDF into." & vbCrLf & vbCrLf & "Press OK to exit .", vbCritical, "Must Specify Destination Folder"
   Exit Sub
End If
xFolder = xFolder + "\" + xSht.Name + "- Report.pdf"

'Check if file already exist
If Len(Dir(xFolder)) > 0 Then
    xYesorNo = MsgBox(xFolder & " already exists." & vbCrLf & vbCrLf & "Do you want to overwrite it?", _
                      vbYesNo + vbQuestion, "File Exists")
    On Error Resume Next
    If xYesorNo = vbYes Then
        Kill xFolder
    Else
        MsgBox "if you don't overwrite the existing PDF, I can't continue." _
                    & vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Exiting "
        Exit Sub
    End If
    If Err.Number <> 0 Then
        MsgBox "Unable to delete existing file.  Please make sure the file is not open or write protected." _
                    & vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Unable to Delete File"
        Exit Sub
    End If
End If

Set xUsedRng = xSht.UsedRange
If Application.WorksheetFunction.CountA(xUsedRng.Cells) <> 0 Then
    'Save as PDF file
    xSht.ExportAsFixedFormat Type:=xlTypePDF, Filename:=xFolder, Quality:=xlQualityStandard

    'Create Outlook email
    Set xOutlookObj = CreateObject("Outlook.Application")
    Set xEmailObj = xOutlookObj.CreateItem(0)
    With xEmailObj
        .Display
        .To = "" [COLOR=rgb(184, 49, 47)][B]PULL RANGE HERE[/B][/COLOR]
        .CC = ""
        .Subject = "Report " & Format(Date - 1, "dd/mm/yyyy")
        .Attachments.Add xFolder
        If DisplayEmail = False Then
            '.Send
        End If
    End With
Else
  MsgBox "The active worksheet cannot be blank"
  Exit Sub
End If

End Sub

 

[Peter_SSs]

i get it from elsewhere.

So if you have a look, you will see that in post #1 you have removed a number of the lines I referred to. Hence the error.

pulls the email addresses in the W range of the workseet and populates them in the TO: field in Outlook

Are all the email addresses to go into the one 'To:' box? That is, are you wanting to send one email to all the recipients (all email addresses will be visible to all recipients) or are you wanting to send an individual email to each recipient separately?

 

[inkbird1]

So if you have a look, you will see that in post #1 you have removed a number of the lines I referred to. Hence the error.

Are all the email addresses to go into the one 'To:' box? That is, are you wanting to send one email to all the recipients (all email addresses will be visible to all recipients) or are you wanting to send an individual email to each recipient separately?

Thanks replaced the code

Send one email to all recipients

 

[Peter_SSs]

Send one email to all recipients

Try replacing this block of code

If Application.WorksheetFunction.CountA(xUsedRng.Cells) <> 0 Then
    'Save as PDF file
    xSht.ExportAsFixedFormat Type:=xlTypePDF, Filename:=xFolder, Quality:=xlQualityStandard

    'Create Outlook email
    Set xOutlookObj = CreateObject("Outlook.Application")
    Set xEmailObj = xOutlookObj.CreateItem(0)
    With xEmailObj
        .Display
        .To = "" 'PULL RANGE HERE
        .CC = ""
        .Subject = "Report " & Format(Date - 1, "dd/mm/yyyy")
        .Attachments.Add xFolder
        If DisplayEmail = False Then
            '.Send
        End If
    End With
Else
  MsgBox "The active worksheet cannot be blank"
  Exit Sub
End If

With this one

If Application.WorksheetFunction.CountA(xUsedRng.Cells) <> 0 Then
    'Save as PDF file
    xSht.ExportAsFixedFormat Type:=xlTypePDF, Filename:=xFolder, Quality:=xlQualityStandard

  'Create Outlook email
  For Each Cell In Worksheets("Lists").Range("W2:W50").Cells.SpecialCells(xlCellTypeConstants)
    ToString = ToString & ";" & Cell.Value
  Next Cell
    Set xOutlookObj = CreateObject("Outlook.Application")
    Set xEmailObj = xOutlookObj.CreateItem(0)
    With xEmailObj
        .Display
        .To = Mid(ToString, 2)
        .CC = ""
        .Subject = "Report " & Format(Date - 1, "dd/mm/yyyy")
        .Attachments.Add xFolder
    End With
Else
  MsgBox "The active worksheet cannot be blank"
  Exit Sub
End If

BTW, if you want to highlight some code in a forum post (like you tried with PULL RANGE HERE you need to use the rich code tags not the vba code tags