Object Variable or with Block Variable Not Set - Error

New Contributor



Until recently the below code was working fine, however when i try to run the macro now i encounter the following error; 


Run-time 91

Object Variable or With Blcok Variable Not Set


For context the macro was taken from https://www.rondebruin.nl/win/s1/outlook/bmail8.htm and edited for the purpose of being able to send emails directly from excel with relevant important information


I have not changed the code or the format, however i did have a security update on my laptop not long ago


I am running on O365


Can you help?





Sub Send_Teams_Without_Coaches_Attachment_1()

Dim OutApp As Object
Dim OutMail As Object
Dim rng As Range
Dim Ash As Worksheet
Dim Cws As Worksheet
Dim Rcount As Long
Dim Rnum As Long
Dim FilterRange As Range
Dim FieldNum As Integer
Dim mailAddress As String
Dim NewWB As Workbook
Dim TempFilePath As String
Dim TempFileName As String
Dim FileExtStr As String
Dim FileFormatNum As Long

On Error GoTo cleanup
Set OutApp = CreateObject("Outlook.Application")

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

'Set filter sheet, you can also use Sheets("MySheet")
Set Ash = (Worksheet)

'Set filter range and filter column (column with names)
Set FilterRange = Ash.Range("A1:U" & Ash.Rows.Count)
FieldNum = 1 'Filter column = A because the filter range start in column A

'Add a worksheet for the unique list and copy the unique list in A1
Set Cws = Worksheets.Add
FilterRange.Columns(FieldNum).AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=Cws.Range("A1"), _
CriteriaRange:="", Unique:=True

'Count of the unique values + the header cell
Rcount = Application.WorksheetFunction.CountA(Cws.Columns(1))

'If there are unique values start the loop
If Rcount >= 2 Then
For Rnum = 2 To Rcount

'Look for the mail address in the MailInfo worksheet
mailAddress = ""
On Error Resume Next
mailAddress = Application.WorksheetFunction. _
VLookup(Cws.Cells(Rnum, 1).Value, _
Worksheets("Mailinfo").Range("A1:B" & _
Worksheets("Mailinfo").Rows.Count), 2, False)
On Error GoTo 0

If mailAddress <> "" Then

'Filter the FilterRange on the FieldNum column
FilterRange.AutoFilter Field:=FieldNum, _
Criteria1:=Cws.Cells(Rnum, 1).Value

'Copy the visible data in a new workbook
With Ash.AutoFilter.Range
On Error Resume Next
Set rng = .SpecialCells(xlCellTypeVisible)
On Error GoTo 0
End With

Set NewWB = Workbooks.Add(xlWBATWorksheet)

With NewWB.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial Paste:=xlPasteValues
.Cells(1).PasteSpecial Paste:=xlPasteFormats
Application.CutCopyMode = False
End With

'Create a file name
TempFilePath = Environ$("temp") & "\"
TempFileName = "Your data of " & Ash.Parent.Name _
& " " & Format(Now, "dd-mmm-yy h-mm-ss")

If Val(Application.Version) < 12 Then
'You use Excel 97-2003
FileExtStr = ".xls": FileFormatNum = -4143
'You use Excel 2007-2016
FileExtStr = ".xlsx": FileFormatNum = 51
End If

'Save, Mail, Close and Delete the file
Set OutMail = OutApp.CreateItem(0)

With NewWB
.SaveAs TempFilePath & TempFileName _
& FileExtStr, FileFormat:=FileFormatNum
On Error Resume Next
With OutMail
.SentOnBehalfOfName = ""
.To = mailAddress
.ReadReceiptRequested = True
.Subject = "Teams Without Qualified Coaches - Charter Standard Health Check"
.Attachments.Add NewWB.FullName
.body = "Hi There" & vbNewLine & _
" " & vbNewLine & _
"As you are aware it is currently Charter Standard Health Check season until the end of January 2020" & vbNewLine & _
" " & vbNewLine & _
"To pass your Health Check you are required to still meet your Charter Standard qualifying criteria" & vbNewLine & _
" " & vbNewLine & _
"With this in mind we have identified your club has the following teams on the attached without a named FA qualified coach" & vbNewLine & _
" " & vbNewLine & _
"If you have a qualified coach assigned to these teams please can you log into the Whole Game System and update the record accordingly, or alternatively read on as to how Birmingham County FA can help" & vbNewLine & _
" " & vbNewLine & _
"The County FA have funding available to support FA Level 1 qualifications for your club, if you are interested please follow the below 6 steps;" & vbNewLine & _
"Step 1: Club secretaries will need to identify 1 individual per team who will be able to access the funding" & vbNewLine & _
"Step 2: Club secretaries MUST ensure that the individuals are uploaded to the Whole Game System" & vbNewLine & _
"Step 3: The identified individual will need to locate a course via http://www.birminghamfa.com/coaches/development-and-courses/fa-level-1-in-coaching-football and inform their secretary of the start and end date along with the course venue" & vbNewLine & _
"Step 4: Club secretaries should add the relevant details for each eligible individual to the following https://app.smartsheet.com/b/form/477a4839810447fa85ae5fe6ca778ec" & vbNewLine & _
"Step 5: On receipt of the completed information secretaries will be issued a discount code specifically for the named individuals" & vbNewLine & _
"Step 6: Named individuals can now book their chosen course using the code supplied. Please note that the code is valid for 1 month only and cannot be reissued" & vbNewLine & _
" " & vbNewLine & _
"Once all teams have the correct qualifications in place please log in to the Whole Game System to complete your Health Check" & vbNewLine & _
" " & vbNewLine & _
"Click the attached link to watch the How to Guide https://youtu.be/DB7xLoBNnUE" & vbNewLine & _
" " & vbNewLine & _
"For support please contact "" & vbNewLine & _
"Kind Regards, Birmingham County FA"

.display 'Or use Send
End With
On Error GoTo 0
.Close savechanges:=False
End With

Set OutMail = Nothing
Kill TempFilePath & TempFileName & FileExtStr
End If

'Close AutoFilter
Ash.AutoFilterMode = False

Next Rnum
End If

On Error Resume Next
Set OutApp = Nothing
Application.DisplayAlerts = False
Application.DisplayAlerts = True

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


0 Replies