Need VBA fixed to export from Outlook
Budget: $30 – $250 USD
I have a script that exports recurring meeting information from 4 different Outlook calendars I manage to Excel. I will provide existing vba. I need to pull the following data for each executive:
start and end date popup windows
Meeting name (excluding certain criteria)
Meeting organizer ***not working***
meeting length in minutes
Required or Optional attendee?
frequency of recurrence (daily, weekly, biweekly, monthly, bimonthly, quarterly)
day of week series is scheduled
time of day series is scheduled
date of next scheduled recurrence ***not working***
date of recurrence expiration (if no expiration leave blank)
list of required attendees ***not working***
list of optional attendees ***not working***
meeting location
then formatted in to a table on each executives worksheet. column width autosized, etc.
IMPORTANT: I am looking for a reliable person who will be able to help me code scripts on a regular basis to increase productivity and save time for a large team of administrative assistants. I am especially interested in a script that will perform a calendar audit for each executive to analyze time spent over the past 6 months and to identify ways to save time, but that will be on another posting.
The problem I am having with current vba is the meeting organizer, required or optional status, and participants do not populate.
Please ask any questions necessary. Please respond with ideas or examples of vba scripts or macros for Outlook. I need someone who has the free time to work fast. I will hire on a regular basis.
Important, if you are going to bid, please send a response to show you read all of my instructions and that you are able to work with me on a regular basis for future jobs. Thank you!
Here is current code:
Sub TrackRecurringMeetings()
Dim OutlookApp As Object
Dim OutlookNamespace As Object
Dim Folder As Object
Dim Appointment As Object
Dim RecPattern As Object
Dim ws As Worksheet
Dim i As Integer
Dim Frequency As String
Dim Executives() As Variant
Dim tbl As ListObject
Dim FromDate As Date
Dim ToDate As Date
FromDate = CDate(InputBox("Enter start date"))
ToDate = CDate(InputBox("Enter end date"))
' Additional keywords to exclude
Dim ExcludedKeywords As Variant
ExcludedKeywords = Array("travel", "doctor", "DNS")
' Array of executive email addresses
Executives = Array("aataaa.com", "batbbb.com", "catccc.com")
' Create Outlook object
Set OutlookApp = CreateObject("Outlook.Application")
Set OutlookNamespace = OutlookApp.GetNamespace("MAPI")
For i = LBound(Executives) To UBound(Executives)
Dim execName As String
execName = Split(Split(Executives(i), "@")(0), ".")(0)
' Check if the sheet already exists, otherwise add a new one
Dim sheetExists As Boolean
sheetExists = False
For Each ws In ThisWorkbook.Sheets
If ws.Name = execName Then
sheetExists = True
Exit For
End If
Next ws
If Not sheetExists Then
Set ws = Sheets.Add(After:=Sheets(Sheets.Count))
ws.Name = execName
Else
Set ws = ThisWorkbook.Sheets(execName)
ws.Cells.Clear
End If
' Headers
Dim headers() As Variant
headers = Array("Meeting Name", "Length", "Frequency", "Day", "Time", "Location", "Organizer", "Pattern Start Date", "Pattern End Date", "Required Status", "Recurrence Pattern")
For j = 0 To UBound(headers)
ws.Cells(1, j + 1).Value = headers(j)
Next j
' Access the Calendar folder
Set Folder = OutlookNamespace.GetSharedDefaultFolder(OutlookNamespace.CreateRecipient(Executives(i)), 9)
Dim LastRow As Long
For Each Appointment In Folder.Items
If Appointment.IsRecurring And Len(Appointment.Subject) > 0 And Appointment.Duration <= 180 Then
' Check for excluded keywords in the subject
If Not ExcludeKeywords(Appointment.Subject) Then
' Check if the meeting expiration date is on or after today
Set RecPattern = Appointment.GetRecurrencePattern
If RecPattern.PatternEndDate >= Date Then
LastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).row + 1
ws.Cells(LastRow, 1).Value = Appointment.Subject
ws.Cells(LastRow, 2).Value = Appointment.Duration
ws.Cells(LastRow, 3).Value = Frequency
Set RecPattern = Appointment.GetRecurrencePattern
Select Case RecPattern.RecurrenceType
Case 0: Frequency = "Daily"
Case 1: Frequency = "Weekly"
Case 2: Frequency = "Monthly"
Case 3: Frequency = "MonthNth"
Case 5: Frequency = "Yearly"
Case 6: Frequency = "YearNth"
Case Else: Frequency = "Unknown"
End Select
ws.Cells(LastRow, 4).Value = WeekdayName(Weekday(Appointment.Start, vbSunday))
ws.Cells(LastRow, 5).Value = Format(Appointment.Start, "HH:mm")
ws.Cells(LastRow, 6).Value = Appointment.Location
ws.Cells(LastRow, 7).Value = GetOrganizerEmailAddress(Appointment)
ws.Cells(LastRow, 8).Value = Format(RecPattern.PatternStartDate, "mm/dd/yyyy")
ws.Cells(LastRow, 9).Value = Format(RecPattern.PatternEndDate, "mm/dd/yyyy")
ws.Cells(LastRow, 10).Value = GetRequiredStatus(Appointment)
ws.Cells(LastRow, 11).Value = GetRecurrencePattern(Appointment)
End If
End If
End If
Next Appointment
' Convert data to table
Set tbl = ws.ListObjects.Add(xlSrcRange, ws.Range("A1").CurrentRegion, , xlYes)
tbl.Name = execName & "_Table"
tbl.TableStyle = "TableStyleMedium9"
' Adjust column widths
ws.Columns("A:L").AutoFit
Next i
MsgBox "Recurring Meetings Extracted Successfully!", vbInformation
End Sub
Function ExcludeKeywords(Subject As String) As Boolean
Dim ExcludedKeywords As Variant
ExcludedKeywords = Array("travel", "doctor", "DNS") ' Add or remove keywords
Dim keyword As Variant
For Each keyword In ExcludedKeywords
If InStr(1, LCase(Subject), LCase(keyword), vbTextCompare) > 0 Then
ExcludeKeywords = True
Exit Function
End If
Next keyword
ExcludeKeywords = False
End Function
Function GetRequiredStatus(Appointment As Object) As String
On Error Resume Next
GetRequiredStatus = IIf(Appointment.Recipients.Item(1).Type = olOptional, "Optional", "Required")
On Error GoTo 0
End Function
Function GetRecurrencePattern(Appointment As Object) As String
On Error Resume Next
GetRecurrencePattern = Appointment.GetRecurrencePattern().PatternString
On Error GoTo 0
End Function
Function GetOrganizerEmailAddress(Appointment As Object) As String
On Error Resume Next
GetOrganizerEmailAddress = Appointment.Organizer.AddressEntry.GetExchangeUser.PrimarySmtpAddress
On Error GoTo 0
End Function
start and end date popup windows
Meeting name (excluding certain criteria)
Meeting organizer ***not working***
meeting length in minutes
Required or Optional attendee?
frequency of recurrence (daily, weekly, biweekly, monthly, bimonthly, quarterly)
day of week series is scheduled
time of day series is scheduled
date of next scheduled recurrence ***not working***
date of recurrence expiration (if no expiration leave blank)
list of required attendees ***not working***
list of optional attendees ***not working***
meeting location
then formatted in to a table on each executives worksheet. column width autosized, etc.
IMPORTANT: I am looking for a reliable person who will be able to help me code scripts on a regular basis to increase productivity and save time for a large team of administrative assistants. I am especially interested in a script that will perform a calendar audit for each executive to analyze time spent over the past 6 months and to identify ways to save time, but that will be on another posting.
The problem I am having with current vba is the meeting organizer, required or optional status, and participants do not populate.
Please ask any questions necessary. Please respond with ideas or examples of vba scripts or macros for Outlook. I need someone who has the free time to work fast. I will hire on a regular basis.
Important, if you are going to bid, please send a response to show you read all of my instructions and that you are able to work with me on a regular basis for future jobs. Thank you!
Here is current code:
Sub TrackRecurringMeetings()
Dim OutlookApp As Object
Dim OutlookNamespace As Object
Dim Folder As Object
Dim Appointment As Object
Dim RecPattern As Object
Dim ws As Worksheet
Dim i As Integer
Dim Frequency As String
Dim Executives() As Variant
Dim tbl As ListObject
Dim FromDate As Date
Dim ToDate As Date
FromDate = CDate(InputBox("Enter start date"))
ToDate = CDate(InputBox("Enter end date"))
' Additional keywords to exclude
Dim ExcludedKeywords As Variant
ExcludedKeywords = Array("travel", "doctor", "DNS")
' Array of executive email addresses
Executives = Array("aataaa.com", "batbbb.com", "catccc.com")
' Create Outlook object
Set OutlookApp = CreateObject("Outlook.Application")
Set OutlookNamespace = OutlookApp.GetNamespace("MAPI")
For i = LBound(Executives) To UBound(Executives)
Dim execName As String
execName = Split(Split(Executives(i), "@")(0), ".")(0)
' Check if the sheet already exists, otherwise add a new one
Dim sheetExists As Boolean
sheetExists = False
For Each ws In ThisWorkbook.Sheets
If ws.Name = execName Then
sheetExists = True
Exit For
End If
Next ws
If Not sheetExists Then
Set ws = Sheets.Add(After:=Sheets(Sheets.Count))
ws.Name = execName
Else
Set ws = ThisWorkbook.Sheets(execName)
ws.Cells.Clear
End If
' Headers
Dim headers() As Variant
headers = Array("Meeting Name", "Length", "Frequency", "Day", "Time", "Location", "Organizer", "Pattern Start Date", "Pattern End Date", "Required Status", "Recurrence Pattern")
For j = 0 To UBound(headers)
ws.Cells(1, j + 1).Value = headers(j)
Next j
' Access the Calendar folder
Set Folder = OutlookNamespace.GetSharedDefaultFolder(OutlookNamespace.CreateRecipient(Executives(i)), 9)
Dim LastRow As Long
For Each Appointment In Folder.Items
If Appointment.IsRecurring And Len(Appointment.Subject) > 0 And Appointment.Duration <= 180 Then
' Check for excluded keywords in the subject
If Not ExcludeKeywords(Appointment.Subject) Then
' Check if the meeting expiration date is on or after today
Set RecPattern = Appointment.GetRecurrencePattern
If RecPattern.PatternEndDate >= Date Then
LastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).row + 1
ws.Cells(LastRow, 1).Value = Appointment.Subject
ws.Cells(LastRow, 2).Value = Appointment.Duration
ws.Cells(LastRow, 3).Value = Frequency
Set RecPattern = Appointment.GetRecurrencePattern
Select Case RecPattern.RecurrenceType
Case 0: Frequency = "Daily"
Case 1: Frequency = "Weekly"
Case 2: Frequency = "Monthly"
Case 3: Frequency = "MonthNth"
Case 5: Frequency = "Yearly"
Case 6: Frequency = "YearNth"
Case Else: Frequency = "Unknown"
End Select
ws.Cells(LastRow, 4).Value = WeekdayName(Weekday(Appointment.Start, vbSunday))
ws.Cells(LastRow, 5).Value = Format(Appointment.Start, "HH:mm")
ws.Cells(LastRow, 6).Value = Appointment.Location
ws.Cells(LastRow, 7).Value = GetOrganizerEmailAddress(Appointment)
ws.Cells(LastRow, 8).Value = Format(RecPattern.PatternStartDate, "mm/dd/yyyy")
ws.Cells(LastRow, 9).Value = Format(RecPattern.PatternEndDate, "mm/dd/yyyy")
ws.Cells(LastRow, 10).Value = GetRequiredStatus(Appointment)
ws.Cells(LastRow, 11).Value = GetRecurrencePattern(Appointment)
End If
End If
End If
Next Appointment
' Convert data to table
Set tbl = ws.ListObjects.Add(xlSrcRange, ws.Range("A1").CurrentRegion, , xlYes)
tbl.Name = execName & "_Table"
tbl.TableStyle = "TableStyleMedium9"
' Adjust column widths
ws.Columns("A:L").AutoFit
Next i
MsgBox "Recurring Meetings Extracted Successfully!", vbInformation
End Sub
Function ExcludeKeywords(Subject As String) As Boolean
Dim ExcludedKeywords As Variant
ExcludedKeywords = Array("travel", "doctor", "DNS") ' Add or remove keywords
Dim keyword As Variant
For Each keyword In ExcludedKeywords
If InStr(1, LCase(Subject), LCase(keyword), vbTextCompare) > 0 Then
ExcludeKeywords = True
Exit Function
End If
Next keyword
ExcludeKeywords = False
End Function
Function GetRequiredStatus(Appointment As Object) As String
On Error Resume Next
GetRequiredStatus = IIf(Appointment.Recipients.Item(1).Type = olOptional, "Optional", "Required")
On Error GoTo 0
End Function
Function GetRecurrencePattern(Appointment As Object) As String
On Error Resume Next
GetRecurrencePattern = Appointment.GetRecurrencePattern().PatternString
On Error GoTo 0
End Function
Function GetOrganizerEmailAddress(Appointment As Object) As String
On Error Resume Next
GetOrganizerEmailAddress = Appointment.Organizer.AddressEntry.GetExchangeUser.PrimarySmtpAddress
On Error GoTo 0
End Function