I currently manually set up the data for reports to be split and sent via outlook using the vba code from the rondebruin.nl site that seems to have been shut down. The original version works find - no links to any tables or queries, I just copy the new data in each month. I have set up a new workbook that is visually identical only now the data is being pulled via power query. For some reason it seems to affect the filtering. I get an error referring to the following code:
FilterRange.AutoFilter Field:=FieldNum, _
Criteria1:=Cws.Cells(Rnum, 1).Value
As mentioned, the exact same code works fine in the version without the power query connections. The data sources and report with the code are all in the same one drive for business path of folders.
The error is:
"Run-time error '1004': Auto-Filter method of Range class failed"
The task partially completes, adding a sheet with the unique rows from column A. After that it should loop through that list and create a new sheet for each of the individual results, do a temp save, send in an email, then I believe it deletes the temp file and continues through the list. By the end the workbook is the same as when it starts. Everything has the same names and is in the same columns.
Hoping someone can help as I have to complete a few of these each month and I'd dearly like to be able to remove some of the manual work involved.
Full code here :
Sub Test_before_send()
'Working in 2000-2016
'For Tips see: Excel Automation - Ron de Bruin
Dim OutApp As Object
Dim OutMail As Object
Dim strbody As String
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 = ActiveSheet
'Set filter range and filter column (column with names)
Set FilterRange = Ash.Range("A1:P" & Ash.Rows.Count)
FieldNum = 1 'Filter column = A because the filter range starts 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("Testemail").Range("A1:B" & _
Worksheets("Testemail").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)
rng.Copy
With NewWB.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial Paste:=xlPasteValues
.Cells(1).PasteSpecial Paste:=xlPasteFormats
.Cells(1).Select
Application.CutCopyMode = False
End With
'Create a file name
TempFilePath = Environ$("temp") & "\"
TempFileName = "Overdue and unplanned leave report for your team " & Ash.Range("F2").Text
If Val(Application.Version) < 12 Then
'You use Excel 97-2003
FileExtStr = ".xls": FileFormatNum = -4143
Else
'You use Excel 2007-2016
FileExtStr = ".xlsx": FileFormatNum = 51
End If
'Save, Mail, Close and Delete the file
Set OutMail = OutApp.CreateItem(0)
strbody = "<p>Please find attached the latest overdue and unplanned leave report for your direct reports. On-call employees are now included in these reports. Balances are converted to days to align with other employee types, however annual leave can only be taken in blocks of weeks (for the purposes of reporting all on-calls show as 5 days to a week, and only entitled leave is shown, accrued leave is excluded). A new column showing whether employees are permanent, fixed-term, or on-call has been added to assist with identification (Emp status).</p>" _
& "This report identifies those employees with overdue annual leave balances (more than two years old) " & _
"which require your immediate attention, and alternate day balances. Alternate day balances require ongoing management. Note that the balances are based on current rostered hours.</p>" _
& "<p>Also included is use of unplanned leave. This is provided to assist you in monitoring and managing the most commonly used types of unplanned leave. There are no specific triggers " & _
"for action related to unplanned leave, but information that may require your attention is highlighted. This includes: </p>" _
& "Balances less than or equal to one day;<p>" _
& "Sick and domestic leave over 12 months that equals or exceeds the employee's annual entitlement." _
& "<br>" & "<p>This report is accurate as at " & Ash.Range("F2").Text & " and may differ from what you see in MyStuff. MyStuff is likely to be more up to date as " & _
"it is refreshed regularly.</p>" _
& "<p>An information sheet is attached with FAQ and definitions. If you have any further queries about the information in this report please" & _
" let me know, or contact your HR Business Partner.</p>" _
& "<p>Kind regards</p>" _
& "<br>" & "<b>Lisa Morgan, People Insights Specialist</b>"
With NewWB
.SaveAs TempFilePath & TempFileName _
& FileExtStr, FileFormat:=FileFormatNum
On Error Resume Next
With OutMail
.to = mailAddress
'.ReplyRecipients.Add "peopleassist@nzpost.co.nz"
'.SentOnBehalfOfName = """People Assist""<peopleassist@nzpost.co.nz>"
.Subject = "Overdue and unplanned leave report for your team " & Ash.Range("F2").Text
.Attachments.Add NewWB.FullName
.Attachments.Add "C:\Users\morganli\OneDrive - NZ Post Group\Regular reports\FAQ and Definitions for Monthly Overdue and Uplanned Leave Reports updated August 2020.pdf"
.HTMLBody = strbody
.Display 'Or use Display or 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
cleanup:
Set OutApp = Nothing
Application.DisplayAlerts = False
Cws.Delete
Application.DisplayAlerts = True
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub
FilterRange.AutoFilter Field:=FieldNum, _
Criteria1:=Cws.Cells(Rnum, 1).Value
As mentioned, the exact same code works fine in the version without the power query connections. The data sources and report with the code are all in the same one drive for business path of folders.
The error is:
"Run-time error '1004': Auto-Filter method of Range class failed"
The task partially completes, adding a sheet with the unique rows from column A. After that it should loop through that list and create a new sheet for each of the individual results, do a temp save, send in an email, then I believe it deletes the temp file and continues through the list. By the end the workbook is the same as when it starts. Everything has the same names and is in the same columns.
Hoping someone can help as I have to complete a few of these each month and I'd dearly like to be able to remove some of the manual work involved.
Full code here :
Sub Test_before_send()
'Working in 2000-2016
'For Tips see: Excel Automation - Ron de Bruin
Dim OutApp As Object
Dim OutMail As Object
Dim strbody As String
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 = ActiveSheet
'Set filter range and filter column (column with names)
Set FilterRange = Ash.Range("A1:P" & Ash.Rows.Count)
FieldNum = 1 'Filter column = A because the filter range starts 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("Testemail").Range("A1:B" & _
Worksheets("Testemail").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)
rng.Copy
With NewWB.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial Paste:=xlPasteValues
.Cells(1).PasteSpecial Paste:=xlPasteFormats
.Cells(1).Select
Application.CutCopyMode = False
End With
'Create a file name
TempFilePath = Environ$("temp") & "\"
TempFileName = "Overdue and unplanned leave report for your team " & Ash.Range("F2").Text
If Val(Application.Version) < 12 Then
'You use Excel 97-2003
FileExtStr = ".xls": FileFormatNum = -4143
Else
'You use Excel 2007-2016
FileExtStr = ".xlsx": FileFormatNum = 51
End If
'Save, Mail, Close and Delete the file
Set OutMail = OutApp.CreateItem(0)
strbody = "<p>Please find attached the latest overdue and unplanned leave report for your direct reports. On-call employees are now included in these reports. Balances are converted to days to align with other employee types, however annual leave can only be taken in blocks of weeks (for the purposes of reporting all on-calls show as 5 days to a week, and only entitled leave is shown, accrued leave is excluded). A new column showing whether employees are permanent, fixed-term, or on-call has been added to assist with identification (Emp status).</p>" _
& "This report identifies those employees with overdue annual leave balances (more than two years old) " & _
"which require your immediate attention, and alternate day balances. Alternate day balances require ongoing management. Note that the balances are based on current rostered hours.</p>" _
& "<p>Also included is use of unplanned leave. This is provided to assist you in monitoring and managing the most commonly used types of unplanned leave. There are no specific triggers " & _
"for action related to unplanned leave, but information that may require your attention is highlighted. This includes: </p>" _
& "Balances less than or equal to one day;<p>" _
& "Sick and domestic leave over 12 months that equals or exceeds the employee's annual entitlement." _
& "<br>" & "<p>This report is accurate as at " & Ash.Range("F2").Text & " and may differ from what you see in MyStuff. MyStuff is likely to be more up to date as " & _
"it is refreshed regularly.</p>" _
& "<p>An information sheet is attached with FAQ and definitions. If you have any further queries about the information in this report please" & _
" let me know, or contact your HR Business Partner.</p>" _
& "<p>Kind regards</p>" _
& "<br>" & "<b>Lisa Morgan, People Insights Specialist</b>"
With NewWB
.SaveAs TempFilePath & TempFileName _
& FileExtStr, FileFormat:=FileFormatNum
On Error Resume Next
With OutMail
.to = mailAddress
'.ReplyRecipients.Add "peopleassist@nzpost.co.nz"
'.SentOnBehalfOfName = """People Assist""<peopleassist@nzpost.co.nz>"
.Subject = "Overdue and unplanned leave report for your team " & Ash.Range("F2").Text
.Attachments.Add NewWB.FullName
.Attachments.Add "C:\Users\morganli\OneDrive - NZ Post Group\Regular reports\FAQ and Definitions for Monthly Overdue and Uplanned Leave Reports updated August 2020.pdf"
.HTMLBody = strbody
.Display 'Or use Display or 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
cleanup:
Set OutApp = Nothing
Application.DisplayAlerts = False
Cws.Delete
Application.DisplayAlerts = True
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub
