Original "start date" of postponed appointment - excel

Hopefully someone could help :)
I use VBA code that runs through Microsoft Outlook Appointments, and for each appointment - prints a few details - to an Excel table.
If I set the start date of an appointment on 01-April-2019, and then postpone that appointment to 12-April-2019, and then postpone that appointment to 15-April-2019 - I have 3 "Appointment Item" objects in my folder.
I would like to print for each appointment in the folder - the "Start Date" that was set originally.
For example: Print for the first appointment - the first original start date (01-April-2019), for the first postponed appointment - the first postponed start date (12-April-2019), and for the second postponed appointment - the second postponed start date (15-April-2019).
However, when I run my code - the last "Start Date" is printed (15-April-2019, 15-April-2019, 15-April-2019), instead of the original (01-April-2019, 12-April-2019, 15-April-2019) .
I read a lot about different types of "date" objects, but couldn't find the correct one.
Could anyone help me?
Thank you very much!
Sub GetFromOutlook()
'Early Binding: Tools > References > Microsoft Outlook xx.0 Object Library > OK
Dim OutlookApp As Outlook.Application
Dim OutlookNS As Namespace
Dim Folder As MAPIFolder
Dim oApp As Outlook.Application
Dim oG As Outlook.Folder 'Method for IMAP, as used by Gmail.
Dim oM As Outlook.MeetingItem
Dim oAA As Outlook.AppointmentItem
Dim oI As Outlook.RecurrencePattern
Dim sMsg$, sAdd$
Dim i As Long
Dim j As Long
Set OutlookApp = New Outlook.Application
Set OutlookNS = OutlookApp.GetNamespace("MAPI")
Set Folder = OutlookNS.GetDefaultFolder(olFolderInbox).Parent.Folders("CCB Meetings")
Dim icon As String
Set oApp = CreateObject("Outlook.Application")
Set oG = OutlookNS.GetDefaultFolder(olFolderInbox).Parent.Folders("CCB Meetings")
For i = 1 To oG.Items.Count
If TypeName(oG.Items(i)) = "MeetingItem" Then j = j + 1
Next i
If j = 0 Then Exit Sub
' Create titles
Range("A1").Offset(0, 0).Value = "SenderName"
Range("B1").Offset(0, 0).Value = "Subject"
Range("C1").Offset(0, 0).Value = "CreationTime (Scheduled time of the first appointment)"
Range("D1").Offset(0, 0).Value = "ReceivedTime (Scheduled time of the current appointment)"
Range("E1").Offset(0, 0).Value = "Start (start time of the last scheduled appointment)"
Range("F1").Offset(0, 0).Value = "StartTime (doesnt work yet)"
Range("G1").Offset(0, 0).Value = "Location"
Range("H1").Offset(0, 0).Value = "RequiredAttendees"
Range("I1").Offset(0, 0).Value = "OptionalAttendees"
Range("J1").Offset(0, 0).Value = "ResponseStatus"
On Error Resume Next
j = 0
For i = 1 To oG.Items.Count
Set oM = oG.Items(i)
With oG.Items(i).GetAssociatedAppointment(True)
j = j + 1
Range("A1").Offset(j, 0).Value = oM.SenderName
Range("B1").Offset(j, 0).Value = oM.Subject
Range("C1").Offset(j, 0).Value = .CreationTime
Range("D1").Offset(j, 0).Value = oM.ReceivedTime
Range("E1").Offset(j, 0).Value = .Start
Range("F1").Offset(j, 0).Value = oAA.GetRecurrencePattern '??????????????????
Range("G1").Offset(j, 0).Value = .Location
Range("H1").Offset(j, 0).Value = .RequiredAttendees
Range("I1").Offset(j, 0).Value = .OptionalAttendees
Range("J1").Offset(j, 0).Value = .ResponseStatus
End With
Next i
On Error GoTo 0
Set Folder = Nothing
Set OutlookNS = Nothing
Set OutlookApp = Nothing
End Sub

You can create a UserProperties field manually or Add a UserProperties field with VBA code.
UserProperties object
UserProperties.Add method
OlUserPropertyType enumeration
Once you have the field you can enter data manually or with VBA.
With VBA consider ItemAdd. Set custom value when item moved to folder in outlook

I have just noticed Niton's latest comment. I think it is an interesting idea. I suspect you still need my investigative macro and you will still need events to create the custom property so this answer should still be useful.
I would need to invest more time than I have available at the moment to address your requirement. This answer includes what I have to hand in the hope that it will help you.
Your code suggests you do not understand recurring entries, you are not familiar with the different types of calendar items and you have misinterpreted some of the properties. If there is any detailed documentation on calendar items available via the internet, I have failed to find it. There is basic documentation (referenced below): this object has these properties; this property is a long/string/enumeration; one sentence definitions and so on. But none of this basic documentation helped me understand how, for example, exceptions related to master entries.
The code below is an Excel based investigation I conducted some months ago. I have not had the time to move to the next stage but I believe it will give you a start.
Option Explicit
Sub DiagCal()
' Outputs major properties of all calendar items within the default
' calendar for a specified date range. The objective is to better
' understand calendar items and how they link.
' Requires reference to Microsoft Outlook nn.n Library
' where "nn.n" identifies the version of Office you are using.
' 27Dec18 First version coded
' 30Dec18 This version coded
' 18Apr19 Reviewed comments and made some improvements.
' * Together these constants identify the start and length of the report period.
' * The report period starts DateReportStartOffset days before today.
' * DateReportLenType and DateReportLen are used as parameters for function DateAdd
' which is used to calculate the report period end date for the start date. See
' function DateAdd for permitted values for these constants.
' * These constants provided a convenient way of specify the start and end date
' of the report period when this macro was written. Something simpler would
' probably be better now.
Const DateReportLen As Long = 1
Const DateReportLenType As String = "yyyy"
Const DateReportStartOffset As Long = -363
Dim AppointToReport As New Collection
Dim AppOutlook As New Outlook.Application
Dim CalEnt As Object
Dim CalEntClass As Long
Dim DateReportEnd As Date
Dim DateReportStart As Date
Dim FileBody As String
Dim FldrCal As Outlook.Folder
Dim InxAir As Long
Dim InxFC As Long
Dim PathDesktop As String
PathDesktop = CreateObject("WScript.Shell").SpecialFolders("Desktop")
' Identify date range to be reported on
DateReportStart = DateSerial(Year(Now), Month(Now), Day(Now) + DateReportStartOffset)
DateReportEnd = DateAdd(DateReportLenType, DateReportLen, DateReportStart)
' This assumes the calendar of interest is the default calendar.
' Change as necessary
Set FldrCal = AppOutlook.Session.GetDefaultFolder(olFolderCalendar)
' This loop reviews the entire calendar and identifies Calendar Items
' that fall entirely or partially within the report period. All such
' Calendar Items are recorded in collection AppointToReport.
For InxFC = 1 To FldrCal.Items.Count
Set CalEnt = FldrCal.Items(InxFC)
' Occasionally I get syncronisation errors. This code avoids them.
CalEntClass = -1
On Error Resume Next
CalEntClass = CalEnt.Class
On Error GoTo 0
' I have never found anything but appointments in
' Calendar but test just in case
If CalEntClass = olAppointment Then
Call DiagCalRecordEntry(CalEnt, DateReportStart, DateReportEnd, AppointToReport)
End If
Next InxFC
FileBody = "Calendar entries within or partially within " & _
Format(DateReportStart, "d mmm yy") & _
" to " & Format(DateReportEnd, "d mmm yy") & vbLf & _
"Total calendar entries: " & FldrCal.Items.Count & vbLf & _
"Calendar entries within or partially within report period: " & _
AppointToReport.Count
' This loop outputs the major properties of every Calendar Items recorded
' in collection AppointToReport.
For InxAir = 1 To AppointToReport.Count
FileBody = FileBody & vbLf & String(70, "=")
FileBody = FileBody & vbLf & AppointToReport(InxAir)(1)
Next
Call PutTextFileUtf8NoBom(PathDesktop & "\Calendar.txt", FileBody)
End Sub
Sub DiagCalRecordEntry(ByRef CalEnt As Object, _
ByVal DateReportStart As Date, _
ByVal DateReportEnd As Date, _
ByRef AppointToReport As Collection, _
Optional ByVal OriginalDate As Date)
' If calendar entry is within or partially within report range, add
' its details to AppointToReport
Dim AllDayEvent As Boolean
Dim AppointDtls As String
Dim AppointId As String
Dim AppointIdMaster As String
Dim BusyStatus As String
Dim DateRecurrEnd As Date
Dim DateRecurrStart As Date
Dim DateAppointEnd As Date
Dim DateAppointStart As Date
Dim DayOfMonth As Long
Dim DayOfWeekMask As String
Dim DayOfWeekMaskCode As Long
Dim DurationEntry As Long
Dim DurationRecurr As Long
Dim InxE As Long
Dim Instance As Long
Dim Interval As Long
Dim Location As String
Dim MonthOfYear As Long
Dim NoEndDate As Boolean
Dim NumOccurrences As Long
Dim RecurrenceState As String
Dim RecurrenceType As String
Dim RecurrPattern As Outlook.RecurrencePattern
Dim Subject As String
Dim TimeStart As Date
Dim TimeEnd As Date
'Debug.Assert False
' Get values from calendar entry which identify if entry is within
' report range
With CalEnt
DateAppointStart = .Start
DateAppointEnd = .End
Select Case .RecurrenceState
Case olApptNotRecurring
'Debug.Assert False
RecurrenceState = "Non-recurring calendar entry"
Case olApptMaster
'Debug.Assert False
RecurrenceState = "Master calendar entry"
Case olApptException
'Debug.Assert False
RecurrenceState = "Exception to Master calendar entry"
Case olApptOccurrence
Debug.Assert False
' I believe this state can only exist if GetOccurrence() is used
' to get a single occurrence of a Master entery. I do not believe
' it can appear as a calendar entry
RecurrenceState = "Occurrence"
Case Else
Debug.Assert False
RecurrenceState = "Unrecognised (" & .RecurrenceState & ")"
End Select
End With
If RecurrenceState = "Master calendar entry" Then
'Debug.Assert False
Set RecurrPattern = CalEnt.GetRecurrencePattern()
With RecurrPattern
DateRecurrStart = .PatternStartDate
DateRecurrEnd = .PatternEndDate
End With
If DateRecurrStart <= DateReportEnd And _
DateRecurrEnd >= DateReportStart Then
' Some or all occurences of this Master entry are within report range
'Debug.Assert False
Else
' No occurences of this Master entry are within report range
'Debug.Assert False
Exit Sub
End If
Else
' Non recurring or exception appointment
If DateAppointStart <= DateReportEnd And _
DateAppointEnd >= DateReportStart Then
' Entry is within report range
'Debug.Assert False
Else
' Non recurring entry is not within report range
'Debug.Assert False
Exit Sub
End If
End If
' Calendar entry is within or partially within report period
' Get remaining properties from entry
'Debug.Assert False
With CalEnt
AllDayEvent = .AllDayEvent
AppointId = .GlobalAppointmentID
Select Case .BusyStatus
Case olBusy
'Debug.Assert False
BusyStatus = "Busy"
Case olFree
'Debug.Assert False
BusyStatus = "Free"
Case olOutOfOffice
'Debug.Assert False
BusyStatus = "Out of Office"
Case olTentative
Debug.Assert False
BusyStatus = "Tentative appointment"
Case olWorkingElsewhere
'Debug.Assert False
BusyStatus = "Working elsewhere"
Case Else
Debug.Assert False
BusyStatus = "Not recognised (" & .BusyStatus & ")"
End Select
Location = .Location
Subject = .Subject
End With
If RecurrenceState = "Exception to Master calendar entry" Then
RecurrenceState = RecurrenceState & vbLf & _
"Master's Id: " & CalEnt.Parent.GlobalAppointmentID & vbLf & _
"Original Date: " & OriginalDate
End If
AppointDtls = RecurrenceState & vbLf & _
"AllDayEvent: " & AllDayEvent & vbLf & _
"AppointId: " & AppointId & vbLf & _
"BusyStatus: " & BusyStatus & vbLf & _
"DateAppointStart: " & DateAppointStart & vbLf & _
"DateAppointEnd: " & DateAppointEnd & vbLf & _
"DurationEntry: " & DurationEntry & vbLf & _
"Location: " & Location & vbLf & _
"Subject: " & Subject
If RecurrenceState <> "Master calendar entry" Then
' AppointDtls complete for this appointment
Call StoreSingleAppoint(Format(DateAppointStart, "yyyymmddhhmm"), _
AppointDtls, AppointToReport)
Else
'Debug.Assert False
With RecurrPattern
' Not all parameters have a meaningful value for all RecurrenceTypes
' but the value always appears to be of the correct data type.
DateRecurrStart = .PatternStartDate
DateRecurrEnd = .PatternEndDate
DayOfMonth = .DayOfMonth
DayOfWeekMaskCode = .DayOfWeekMask
DayOfWeekMask = ""
If DayOfWeekMaskCode >= olSaturday Then
Debug.Assert False
DayOfWeekMask = "+Saturday"
DayOfWeekMaskCode = DayOfWeekMaskCode - olSaturday
End If
If DayOfWeekMaskCode >= olFriday Then
'Debug.Assert False
DayOfWeekMask = "+Friday" & DayOfWeekMask
DayOfWeekMaskCode = DayOfWeekMaskCode - olFriday
End If
If DayOfWeekMaskCode >= olThursday Then
'Debug.Assert False
DayOfWeekMask = "+Thursday" & DayOfWeekMask
DayOfWeekMaskCode = DayOfWeekMaskCode - olThursday
End If
If DayOfWeekMaskCode >= olWednesday Then
'Debug.Assert False
DayOfWeekMask = "+Wednesday" & DayOfWeekMask
DayOfWeekMaskCode = DayOfWeekMaskCode - olWednesday
End If
If DayOfWeekMaskCode >= olTuesday Then
'Debug.Assert False
DayOfWeekMask = "+Tuesday" & DayOfWeekMask
DayOfWeekMaskCode = DayOfWeekMaskCode - olTuesday
End If
If DayOfWeekMaskCode >= olMonday Then
'Debug.Assert False
DayOfWeekMask = "+Monday" & DayOfWeekMask
DayOfWeekMaskCode = DayOfWeekMaskCode - olMonday
End If
If DayOfWeekMaskCode >= olSunday Then
'Debug.Assert False
DayOfWeekMask = "+Sunday" & DayOfWeekMask
End If
If DayOfWeekMask = "" Then
'Debug.Assert False
DayOfWeekMask = "None"
Else
'Debug.Assert False
DayOfWeekMask = Mid$(DayOfWeekMask, 2) ' Remove leading +
End If
DurationRecurr = .Duration
Instance = .Instance
Interval = .Interval
MonthOfYear = .MonthOfYear
NoEndDate = .NoEndDate
NumOccurrences = .Occurrences
Select Case .RecurrenceType
Case olRecursDaily
'Debug.Assert False
RecurrenceType = "Daily"
Case olRecursMonthly
Debug.Assert False
RecurrenceType = "Monthly"
Case olRecursMonthNth
Debug.Assert False
RecurrenceType = "MonthNth"
Case olRecursWeekly
'Debug.Assert False
RecurrenceType = "Weekly"
Case olRecursYearly
'Debug.Assert False
RecurrenceType = "Yearly"
Case olRecursYearNth
Debug.Assert False
RecurrenceType = "YearNth"
Case Else
Debug.Assert False
RecurrenceType = "Unrecognised Value (" & RecurrenceType & ")"
End Select
TimeStart = .StartTime
TimeEnd = .EndTime
End With
AppointDtls = AppointDtls & vbLf & "DateRecurrStart: " & DateRecurrStart _
& vbLf & "DateRecurrEnd: " & DateRecurrEnd _
& vbLf & "DayOfMonth: " & DayOfMonth _
& vbLf & "DayOfWeekMask: " & DayOfWeekMask _
& vbLf & "DurationRecurr: " & DurationRecurr _
& vbLf & "Instance: " & Instance _
& vbLf & "Interval: " & Interval _
& vbLf & "MonthOfYear: " & MonthOfYear _
& vbLf & "NoEndDate: " & NoEndDate _
& vbLf & "NumOccurrences: " & NumOccurrences _
& vbLf & "RecurrenceType: " & RecurrenceType _
& vbLf & "TimeStart: " & TimeStart & " (" & CDbl(TimeStart) & ")" _
& vbLf & "TimeEnd: " & TimeEnd & " (" & CDbl(TimeEnd) & ")"
For InxE = 1 To RecurrPattern.Exceptions.Count
AppointDtls = AppointDtls & vbLf & "Exception " & InxE & " for occurrence on " & _
RecurrPattern.Exceptions.Item(InxE).OriginalDate
Next
Call StoreSingleAppoint(Format(DateRecurrStart, "yyyymmddhhmm"), _
AppointDtls, AppointToReport)
For InxE = 1 To RecurrPattern.Exceptions.Count
Call DiagCalRecordEntry(RecurrPattern.Exceptions.Item(InxE).AppointmentItem, _
DateReportStart, DateReportEnd, AppointToReport, _
RecurrPattern.Exceptions.Item(InxE).OriginalDate)
Next
End If ' RecurrenceState <> "Master calendar entry"
End Sub
Public Sub PutTextFileUtf8NoBom(ByVal PathFileName As String, ByVal FileBody As String)
' Outputs FileBody as a text file named PathFileName using
' UTF-8 encoding without leading BOM
' Needs reference to "Microsoft ActiveX Data Objects n.n Library"
' Addition to original code says version 2.5. Tested with version 6.1.
' 1Nov16 Copied from http://stackoverflow.com/a/4461250/973283
' but replaced literals with parameters.
' 15Aug17 Discovered routine was adding an LF to the end of the file.
' Added code to discard that LF.
' 11Oct17 Posted to StackOverflow
' 9Aug18 Comment from rellampec suggested removal of adWriteLine from
' WriteTest statement would avoid adding LF.
' 30Sep18 Amended routine to remove adWriteLine from WriteTest statement
' and code to remove LF from file. Successfully tested new version.
' References: http://stackoverflow.com/a/4461250/973283
' https://www.w3schools.com/asp/ado_ref_stream.asp
Dim BinaryStream As Object
Dim UTFStream As Object
Set UTFStream = CreateObject("adodb.stream")
UTFStream.Type = adTypeText
UTFStream.Mode = adModeReadWrite
UTFStream.Charset = "UTF-8"
UTFStream.Open
UTFStream.WriteText FileBody
UTFStream.Position = 3 'skip BOM
Set BinaryStream = CreateObject("adodb.stream")
BinaryStream.Type = adTypeBinary
BinaryStream.Mode = adModeReadWrite
BinaryStream.Open
UTFStream.CopyTo BinaryStream
UTFStream.Flush
UTFStream.Close
Set UTFStream = Nothing
BinaryStream.SaveToFile PathFileName, adSaveCreateOverWrite
BinaryStream.Flush
BinaryStream.Close
Set BinaryStream = Nothing
End Sub
Sub StoreSingleAppoint(ByVal SeqKey As String, _
ByVal AppointDtls As String, _
ByRef AppointToReport As Collection)
' Entries in AppointToReport are of the form:
' VBA.Array(SeqKey, AppointDtls)
' Add new entry to AppointToReport so entries are in ascending order by SeqKey
Dim InxAtr As Long
If AppointToReport.Count = 0 Then
'Debug.Assert False
' first appointment
AppointToReport.Add VBA.Array(SeqKey, AppointDtls)
Else
For InxAtr = AppointToReport.Count To 1 Step -1
If SeqKey >= AppointToReport(InxAtr)(0) Then
' New appointment belongs after this existing entry
'Debug.Assert False
AppointToReport.Add VBA.Array(SeqKey, AppointDtls), , , InxAtr
Exit Sub
End If
Next
' If get here, new appointment belongs before all existing appointments
'Debug.Assert False
AppointToReport.Add VBA.Array(SeqKey, AppointDtls), , 1
End If
End Sub
Create a macro-enabled workbook and copy the above code to a module.
Near the top of the code you will find:
' Identify date range to be reported on
DateReportStart = DateSerial(Year(Now), Month(Now), Day(Now) + DateReportStartOffset)
DateReportEnd = DateAdd(DateReportLenType, DateReportLen, DateReportStart)
I suggest replacing these statements with something simple like:
DateReportStart = #4/15/2019#
DateReportEnd = #4/18/2019#
Warning: VBA date literals use middle-endian format which confuses everyone except civilian Americans.
Macro DiagCal() creates a desktop file named “Calendar.txt” containing details of every calendar item that is entirely or partially within the report period. When I tested it, I created every sort of calendar entry: single appointments; entries recurring by day, week, month, year; weekly patterns; multi-day, all-day and part-day events; exceptions to instances of recurring entries and so on.
Visit https://learn.microsoft.com/en-us/office/vba/api/Outlook.AppointmentItem
On the left is an index with entries for the events, methods and properties of an appointment item. Expand the properties and methods and look for information that did not interest me but might interest you. Look through my code and workout how to add that information. If you cannot see how to add information, report the information you want in a comment and I will add it for you.
Expand the events and study what is available. I have never used appointment item events. I have found events easy enough to use with mail items so I assume appointment items will be similar. It is not immediate clear to me which would be the best events to use. I think you need to know when a new item is added and when an item is changed. I would try some of these events and write code to output a few properties to the Immediate Windows to better understand when these events are triggered and what data is available.
I believe you will have to initialise your workbook with code something like my macro which extracts the interesting properties of existing appointment items. You then need events to output the interesting properties of new or changed events.
I would not use events to update the workbook. (1) If you update the workbook in real time there will probably be a noticeable delay while the event is processed. (2) The update code is likely to be complex and unlikely to be correct on first attempt. If you update the workbook in real time, you will have to cause the events to be triggered again and again until you get the code right.
I would get each event to output a small text file, containing the interesting properties, to a suitable disc folder. Outputting a text file will be take little time and should not be noticeable to the user. These text files can be used again and again to update the workbook until you get the code right.
I hope the above gives you some ideas.

Related

How do I search between two date ranges in VBA?

I have hit a stumbling block and could just do with some assistance please.
I have been tasked with creating a VBA Macro that looks between two date ranges in a shared inbox sub-folder in Outlook.
If the code finds any Excel documents attached to the emails within that date range it will extract the attachments and will put them into a designated shared drive folder. All of this i had working perfectly, however, I now need to change the code slightly so that on a separate sheet it adds the date the code was last ran (this I have working also) and when the code is next ran it takes the date it last ran as the "Date from" date and searches between that date and whatever the date and time is of the time you are trying to execute the code again - this is where my code isn't working.
Here is my code so far (I am not a VBA expert and some terminology may not be correct so please go easy on my code) - I have had to replace certain sensitive info with "xxxxxx" in the code below.
Sub saveOutlookAttachments()
' For this to work, you need to ensure "Microsoft Office 16.0 Object Library" is ticked
' You can find the object library in Tools -> References
' -- start of initialise all the outlook library details needed
Dim ol As Outlook.Application
Dim ns As Outlook.Namespace
Dim fol As Outlook.Folder
Dim i As Object
Dim mi As Outlook.MailItem
Dim at As Outlook.attachment
Dim Folder As MAPIFolder
Dim OutlookMail As Variant
' -- end of initialise all the outlook library details needed
' -- start of Date from and to initialising
Dim DateStart As Date
Dim DateEnd As Date
Dim DateToCheck As String
' Get the date last ran
If Sheet2.Cells(1, 2) <> "" Then
Sheet1.Cells(2, 2) = Sheet2.Cells(1, 2)
Debug.Print "Start Date is: "; Sheet1.Cells(2, 2)
Sheet1.Cells(2, 4) = Now()
Debug.Print "End Date is: "; Sheet1.Cells(2, 4)
Else
Sheet2.Cells(1, 2) = ""
Debug.Print Sheet1.Cells(2, 2)
End If
DateStart = Sheet1.Cells(2, 2) ' Cell B2
DateEnd = Sheet1.Cells(2, 4) ' Cell B4
DateToCheck = "[ReceivedTime] >= """ & DateStart & """ And [ReceivedTime] <= """ & DateEnd & """"
Debug.Print "Date to Check is: "; DateToCheck
' -- end of Date from and to initialising
' -- start of Set ol and Set ns
Set ol = New Outlook.Application
Set ns = ol.GetNamespace("MAPI")
' -- end of Set ol and Set ns
' Which folder should the script be reading from?
Set fol = ns.Folders("~ xxxxxxx ").Folders("Inbox").Folders("xxxxxxxx")
' if there is an error when the code runs then stop the script and go straight to "errordetails" found at the bottom of the screen
On Error GoTo errordetails
' For each email in the folder (Restricted to the date range entered on the Spreadsheet)
For Each i In fol.Items.Restrict(DateToCheck)
' If the email is an Outlook email
If i.Class = OlMail Then
Set mi = i
UserForm1.Show
' If there are more than 0 attachments, ie, if it finds an attachment
If mi.Attachments.Count > 0 Then
For Each at In mi.Attachments
'Debug.Print mi.SenderName & " " & mi.ReceivedTime ' <- uncomment this part if you need to debug (remember to open the "immediate" window also
' Look for attachments that contain ".xls" (this will also pick up ".xlsx" and ".xlsm" etc
If InStr(LCase(at.FileName), ".xls") > 0 Then
' Tell the script where to save the file and what details need to be appeneded to the file name to make it a unique name
at.SaveAsFile "\\xxxx\xxxxx\xxxxx\" & Format(mi.ReceivedTime, "yyyy-mm-dd hh-nn-ss") & at.FileName
Else
' literally do nothing (it's probably not needed but added just in case)
End If
Next at
End If
End If
Next i
UserForm1.Hide
CountNumberOfFiles
Sheet2.Cells(1, 1) = "Date last ran was"
Sheet2.Cells(1, 2) = Now()
errordetails:
Debug.Print "Error number: " & Err.Number _
& " " & Err.Description;
End Sub
Sub CountNumberOfFiles()
Dim FolderPath As String
Dim Path As String
Dim Count As Integer
FolderPath = "\\xxxx\xxxxxxx\xxxxxxxxx"
Path = FolderPath & "\*"
FileName = Dir(Path)
Do While FileName <> ""
Count = Count + 1
FileName = Dir()
Loop
MsgBox "Search completed. There are " & Count & " attachments extracted to the folder \\xxxxxx\xxxxxx\xxxx"
End Sub
In the Immediate window, the Debug.Print for this part does show all the correct dates and times but it says it finds nothing even when there is one item that definitely matches.
' Get the date last ran
If Sheet2.Cells(1, 2) <> "" Then
Sheet1.Cells(2, 2) = Sheet2.Cells(1, 2)
Debug.Print "Start Date is: "; Sheet1.Cells(2, 2)
Sheet1.Cells(2, 4) = Now()
Debug.Print "End Date is: "; Sheet1.Cells(2, 4)
Else
Sheet2.Cells(1, 2) = ""
Debug.Print Sheet1.Cells(2, 2)
End If
DateStart = Sheet1.Cells(2, 2) ' Cell B2
DateEnd = Sheet1.Cells(2, 4) ' Cell B4
DateToCheck = "[ReceivedTime] >= """ & DateStart & """ And [ReceivedTime] <= """ & DateEnd & """"
Debug.Print "Date to Check is: "; DateToCheck
' -- end of Date from and to initialising
Thank you in advance for any assistance provided.
Dates are DateTime, not Text, so create text expressions for the date values:
DateToCheck = "[ReceivedTime] >= #" & Format(DateStart, "yyyy\/mm\/dd") & "# And [ReceivedTime] <= #" & Format(DateEnd, "yyyy\/mm\/dd") & "#"
Addendum:
Looking up the docs (always highly recommended), it appears that criteria must be text:
Although dates and times are typically stored with a Date format, the
Find and Restrict methods require that the date and time be converted
to a string representation. To make sure that the date is formatted as
Outlook expects, use the Format function. The following example
creates a filter to find all contacts that have been modified after
January 15, 1999 at 3:30 P.M.
Example:
sFilter = "[LastModificationTime] > '" & Format("1/15/99 3:30pm", "ddddd h:nn AMPM") & "'"
So, I guess you filter should read:
DateToCheck = "[ReceivedTime] >= '" & Format(DateStart, "ddddd h:nn AMPM") & "' And [ReceivedTime] <= '" & Format(DateEnd, "ddddd h:nn AMPM") & "'"

MailMerge: From Excel to Word Saving Individual Documents for Each Record While Maintaining Link to Source

First I want to say I am extremely new to utilizing VBA to make my excel sheets more efficient.
I started a few months back and mainly generate code by piecing together what I find online then edit to meet my specific needs.
What Current Code Does:
What I have created allows me to perform a multiple document mailmerge from excel to merge records from my datasoure (Project Information) with the click of a button. Before performing the merge, the user identifies 5 conditions;
Zoning (ex. R20; located in cell C8)
Easement Type (ex. TE; located in cell F8)
The Template to use from the previously uploaded template list (located in cell J8)
The Area of the Lot (located in cell P8)
If it is a just compensation Report ("yes" or "no" located in cell C11)
The criteria above identifies the record numbers that match the specified criteria to create individual mailmerge documents for each record and saves in the corresponding property file which is associated with the record number. The sheet that is generating mailmerge ("report Creation") is different from the datasource and maintains records of when the mailmerge was performed and what template was used. This sheet also contains the list of records and is the search range for the criteria (record start on line 39 so +37 is used to match "Report Creation" row).The code also contains a loading bar that appears when the merging is being performed and shows percentage complete (percentage is not correct but used more to show user merge is in progress).
My Question:
What I am now trying to adjust is when the mailmerge is performed I still want the individual documents but I want to maintain the link between the new document and the datasource. That way I can always update the word document if any changes occur. It currently merges to a word document that no longer contains any mailmerge field and is as if I finalized a merge.
I am assuming this is a minor change after the .opendatasource but cant pinpoint what to change.
My Code may be a bit messy and could definitely use some cleanup but it gets the job done. See below.
Current Code:
Sub RunMerge()
Dim StrMMSrc As String, StrMMDoc As String, StrMMDocName As String, StrName As String, dataname As String
Dim i As Long
Dim Load As Integer
Dim wdApp As New Word.Application
Dim wdDoc As Word.Document
Dim ReportNum, AddressName, SaveLoc, NewFile, fpath, subfldr, DateCr As String
Dim ExpTemp, ExTempDate, ExpReview, ExpRevDate As Range
Dim ExpRow, CustCol, lastRow, StrMMDocRow, ExportedDoc, LotSizeSM, LotSizeLG, ActualLS, symbpos As Long
Dim FileName, Zoning, Ease, LotSizeRNG, Ztype, Etype As String
On Error GoTo errhandler
'Turn off at the start
TurnOffFunctionality
wdApp.DisplayAlerts = wdAlertsNone
Set wsreports = ThisWorkbook.Worksheets("Report Creation")
Set wsinfo = ThisWorkbook.Worksheets("Project Information")
Set wsdetails = ThisWorkbook.Worksheets("Project Details")
StrMMSrc = ThisWorkbook.fullname
lastRow = wsinfo.Columns("A").Find("*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows, LookIn:=xlValues).row
dataname = wsinfo.Name
'set folder path for saving documents
fpath = ThisWorkbook.Sheets("Project Details").Range("E30").Value
subfldr = wsdetails.Range("F34").Value
'date exported
DateCr = Format(Date, "mm-dd-yyyy")
ExportedDoc = 0
With wsreports
' set range criteria
LotSizeRNG = .Range("P8").Value
symbpos = InStr(1, LotSizeRNG, "<>")
LotSizeSM = CInt(Left(LotSizeRNG, symbpos - 1))
LotSizeLG = CInt(Mid(LotSizeRNG, symbpos + 2))
If LotSizeLG = "" Then LotSizeLG = 100000000
If wsreports.Range("J8").Value = Empty Then
MsgBox "Please Select A Template From The Dropdown List to Export"
wsreports.Range("J8").Select
GoTo errhandler
End If
StrMMDocRow = .Application.Match(Range("J8").Value, .Range("C1:C34"), 0) 'Set Template Row
StrMMDocName = .Range("J8").Value 'set template name
Zoning = .Range("C8").Value 'set Zoning Criteria
Ease = .Range("F8").Value 'Set Easement Criteria
StrMMDoc = .Range("AB" & StrMMDocRow).Value 'Word Document Filename
End With
wdApp.Visible = False
Set wdDoc = wdApp.Documents.Open(FileName:=StrMMDoc, AddToRecentFiles:=False)
With wdDoc
With .MailMerge
.MainDocumentType = wdFormLetters
.OpenDataSource Name:=StrMMSrc, AddToRecentFiles:=False, LinkToSource:=False,
ConfirmConversions:=False, _
ReadOnly:=True, Format:=wdOpenFormatAuto, Connection:="Provider=Microsoft.ACE.OLEDB.12.0;" & _
"User ID=Admin;Data Source=" & StrMMSrc & ";Mode=Read;Extended Properties=""HDR=YES;IMEX=1;"";", _
SQLStatement:="SELECT * FROM `Project Information$`", SQLStatement1:="", SubType:=wdMergeSubTypeAccess
UserFormLoad.Show
For i = 2 To lastRow
Ztype = wsreports.Range("D" & i + 37).Value
Etype = wsreports.Range("F" & i + 37).Value
ActualLS = wsreports.Range("E" & i + 37).Value
'Check the row for matching zone and easement cristeria
If wsreports.Range("C11").Value = "No" And StrMMDocName <> wsreports.Range("H" & i + 37).Value _
And Ztype = Zoning And ActualLS >= LotSizeSM And ActualLS <= LotSizeLG And Etype = Ease Then
ExportedDoc = ExportedDoc + 1
'set newfile location
ReportNum = wsreports.Range("B" & i + 37).Value
AddressName = wsreports.Range("C" & i + 37).Value
SaveLoc = fpath & "\#" & ReportNum & "_" & AddressName & "\" & subfldr
'generate new file name with date
NewFile = SaveLoc & "\" & AddressName & "_Draft Report_" & DateCr & ".docx"
.Destination = wdSendToNewDocument
.SuppressBlankLines = True
With .DataSource
.FirstRecord = i - 1
.LastRecord = i - 1
.ActiveRecord = i - 1
StrName = NewFile
End With
.Execute Pause:=False
wsreports.Range("I" & i + 37).Value = StrMMDocName
wsreports.Range("L" & i + 37).Value = DateCr
With wdApp.ActiveDocument
.SaveAs FileName:=StrName, FileFormat:=wdFormatXMLDocument, AddToRecentFiles:=False
' and/or:
'.SaveAs Filename:=StrMMPath & StrName & ".pdf", FileFormat:=wdFormatPDF, AddToRecentFiles:=False
.Close savechanges:=False
End With
Dim r As Integer
r = i
Load = Application.WorksheetFunction.RoundDown((r + 1) / (lastRow) * 100, 0)
DoEvents
UserFormLoad.LoadBar.Width = Load / 100 * 222
UserFormLoad.LabelProg.Caption = Load & "%"
End If
Next i
Unload UserFormLoad
.MainDocumentType = wdNotAMergeDocument
End With
.Close savechanges:=False
End With
If ExportedDoc = 0 Then
MsgBox "No Properties Matched The Criteria Specified. Use The Table To Verify The Easement and Zoning Have Properties Meeting Criteria.", vbOKOnly, "No Matches Found"
Else
MsgBox "The Property Draft Reports Were Exported Successfully. Please Check Project Property" & subfldr & " Folder for Word Document.", vbOKOnly, "Export Successfull"
End If
'cleanup if error
errhandler:
TurnOnFunctionality
wdApp.DisplayAlerts = wdAlertsAll
Set wdDoc = Nothing
Set wdApp = Nothing
End Sub
You cannot use mailmerge for what you want to achieve. You would need to use LINK fields instead of MERGEFIELDs and update the LINK field row references for each output document.
An alternative approach would be to re-run the mailmerge for just the record(s) you want to update.

Sending Data from Word Into Excel: Run-time error: '424' Object Required

I am trying to send data to Excel from Word after an email is sent. I have the email and the rest of it working. Now, I am trying to get the part with Excel working.
Private Sub btnGenerateEmail_Click()
'Instatiate Application Objects (using late binding)
Dim App As Object
Dim Msg As Object
Const olMailItem As Long = 0
'Declare Form Variables
Dim EmplName As String: EmplName = Me.frmEmployeeName
Dim IncidentDesc As String: IncidentDesc = Me.frmIncidentDescription
Dim EmplTrain As String: EmplTrain = Me.frmEmployeeTraining
Dim FaceOnRack As String: FaceOnRack = Me.frmFaceOnRack
Dim DrawingProb As String: DrawingProb = Me.frmDrawingProblem
Dim JobNum As String: JobNum = Me.frmJobNumber
Dim DrwNum As String: DrwNum = Me.frmDrawingNumber
Dim FaceDesc As String: FaceDesc = Me.frmFaceDescription
Dim Qty As String: Qty = Me.frmQty
Dim StockOrNon As String: StockOrNon = Me.frmStockOrNon
Dim FaceReplace As String: FaceReplace = Me.frmFaceReplace
'Set Application Objects (using late binding)
Set App = CreateObject("Outlook.Application")
Set Msg = App.CreateItem(olMailItem)
'Data validation
If IsNull(EmplName) Or EmplName = "" Then
MsgBox ("Please enter the employee's name."), vbCritical
Exit Sub
End If
If IsNull(IncidentDesc) Or IncidentDesc = "" Then
MsgBox ("Please describe how the face was broken."), vbCritical
Exit Sub
End If
If IsNull(EmplTrain) Or EmplTrain = "" Then
MsgBox ("Does the employee need more training to avoid these kind of incidents in the future?"), vbCritical
Exit Sub
End If
If IsNull(FaceOnRack) Or FaceOnRack = "" Then
MsgBox ("Was the already broken when on rack?"), vbCritical
Exit Sub
End If
If IsNull(DrawingProb) Or DrawingProb = "" Then
MsgBox ("Was the face scrapped because of an issue with the drawing/art?"), vbCritical
Exit Sub
End If
If IsNull(JobNum) Or JobNum = "" Then
MsgBox ("Please enter the job number or traveler number."), vbCritical
Exit Sub
End If
If IsNull(DrwNum) Or DrwNum = "" Then
MsgBox ("Please enter the drawing number."), vbCritical
Exit Sub
End If
If IsNull(FaceDesc) Or FaceDesc = "" Then
MsgBox ("Please enter a description of the face being scrapped."), vbCritical
Exit Sub
End If
If IsNull(Qty) Or Qty = "" Then
MsgBox ("Please enter the quantity being scrapped."), vbCritical
Exit Sub
End If
If IsNull(StockOrNon) Or StockOrNon = "" Then
MsgBox ("Is the face stock or non-stock?"), vbCritical
Exit Sub
End If
If IsNull(FaceReplace) Or FaceReplace = "" Then
MsgBox ("Does this face need to be replaced?"), vbCritical
Exit Sub
End If
'Compose HTML Message Body
Dim HTMLContent As String
HTMLContent = "<p style='font-family:Calibri; font-size:14px;'>This email is an autogenerated scrap face incident report.</p>" _
& "<table style='font-family:Calibri; font-size:14px;' width='75%' border='1' bordercolor='black' cellpadding='5'>" _
& "<tr><td width='65%'>Employee Name</td><td>" & EmplName & "</td></tr>" _
& "<tr><td>How was the face broken?</td><td>" & IncidentDesc & "</td></tr>" _
& "<tr><td>Does employee in question need more training to prevent future incidents?</td><td>" & EmplTrain & "</td></tr>" _
& "<tr><td>Was the face found on the rack already broken?</td><td>" & FaceOnRack & "</td></tr>" _
& "<tr><td>Was the face scrapped because of an issue with the drawing/art?</td><td>" & DrawingProb & "</td></tr>" _
& "<tr><td>Job/Traveler Number:</td><td>" & JobNum & "</td></tr>" _
& "<tr><td>Drawing Number:</td><td>" & DrwNum & "</td></tr>" _
& "<tr><td>Face Description:</td><td>" & FaceDesc & "</td></tr>" _
& "<tr><td>Quantity</td><td>" & Qty & "</td></tr>" _
& "<tr><td>Stock or Non-Stock</td><td>" & StockOrNon & "</td></tr>" _
& "<tr><td>Does this face need to be replaced?</td><td>" & FaceReplace & "</td></tr>" _
& "</table>"
'Construct the email, pass parameter values, & send the email
With Msg
.To = "test#test.com"
.Subject = "Scrap Face Incident Report"
.HTMLBody = HTMLContent
.Display
'.Send
End With
'MAY NEED WORK
'Make sure the generated email is the active window
App.ActiveWindow.WindowState = olMaximized
'Application.Windows("Scrap Face Incident Report - Message (HTML)").Activate
'Create entry in scrap report
Dim ScrapReportFile As String
ScrapReportFile = "\\jacksonville-dc\common\SOP's for JV\WIP\Jonathan\JG - How to Replace Scrapped Faces\Scrap List (Faces).xlsx"
'File exists
If Dir(ScrapReportFile) <> "" Then
Dim ObjExcel As Object, ObjWb As Object, ObjWorksheet As Object
Set ObjExcel = CreateObject("EXCEL.APPLICATION")
Set ObjWb = ObjExcel.Workbooks.Open(ScrapReportFile)
ObjExcel.Visible = True
With ObjWb.Worksheets(3)
Dim lastrow As Long: lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
MsgBox (lastrow)
End With
'ObjWb.Worksheets(1).Range("A1") = "SOP Title: " & SOPTitle
'ObjWb.Worksheets(1).Range("F1") = "Date: " & Format(Now, "MM/dd/yyyy")
'ObjWb.Save
'ObjWb.Close
End If
'File does not exist; throw error
End Sub
On this section of code:
With ObjWb.Worksheets(3)
Dim lastrow As Long: lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
MsgBox (lastrow)
End With
I am trying to send the data gathered from the form and create a new row at the bottom of the sheet and then insert the data into specified columns. When I am doing the .Cells(.Rows.Count...etc I am getting an error.
Run-time error: '424' Object Required
Word doesn't know what xlUp is, because that is from the Excel object model.
Add the following line:
Const xlUp as Long = -4162
as per the documentation of xlUps corresponding value.

Excel MailMerge Export to PDF

Im trying to generate offer letters based on details provide and mail merge it. But i want my output in PDF Format instead of word.
Since it exports the file in word, i want that the final output that is generated is a PDF. But whenever i am trying i am facing with the same error.
Im getting System Error &H80004005 Unspecified Error.
Sub cmdAgree_Click()
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Application.ReferenceStyle = xlA1
' Sheets("DATA").Select
' ActiveSheet.Range("A1").Select
' Selection.End(xlDown).Select
' row_ref = Selection.Row
'
' Sheets("Mail Merge").Range("D4").Value = row_ref
Sheets("Mail Merge").Select
frst_rw = Sheets("Mail Merge").Range("D6").Value
lst_rw = Sheets("Mail Merge").Range("D7").Value
' ActiveWorkbook.Save
'Loop to check if the start row is greater than the last actioned row
If frst_rw = 1 Then
MsgBox "Start row can't be 1. Please check and update to proceed!", vbCritical
Exit Sub
End If
If Sheets("Data").Range("A" & frst_rw).Value = "" Then
MsgBox "No Data to work upon. Please check the reference row used!!!"
Exit Sub
End If
' If frst_rw <= Sheets("Mail Merge").Range("D5").Value And Sheets("Mail Merge").Range("D5").Value <> "" Then
' MsgBox "Start from Row: Cant be less than last actioned row of data in the DATA tab." & vbNewLine _
' & "Please check and update to proceed!", vbCritical
' Exit Sub
' End If
'Loop to check if the last row to generate is greater than the total rows of data
' If lst_rw > Sheets("Mail Merge").Range("D4").Value Then
' MsgBox "End at Row: Cant be greater than total data rows in the DATA tab." & vbNewLine _
' & "Please check and update to proceed!", vbCritical
' Exit Sub
' Else
'Update the last actioned row for future reference
Sheets("Mail Merge").Range("D5").Value = Sheets("Mail Merge").Range("D7").Value
' End If
'Loop though the start row and end row to generate the word documents for different candidates
Dim wd As Object
Dim wdocSource As Object
Dim strWorkbookName As String
On Error Resume Next
'agreement_folder = ThisWorkbook.Path & "\Agreement Template\"
For x = frst_rw - 1 To lst_rw - 1
' For x = frst_rw To lst_rw
'This if condition tackles the choice of group company basis which the template gets selected
If Sheets("DATA").Range("AS" & x + 1).Value = "APPLE" Then
agreement_folder = ThisWorkbook.Path & "\Agreement Template - APPLE\"
ElseIf Sheets("DATA").Range("AS" & x + 1).Value = "BANANA" Then
agreement_folder = ThisWorkbook.Path & "\Agreement Template - BANANA\"
ElseIf Sheets("DATA").Range("AS" & x + 1).Value = "CHERRY" Then
agreement_folder = ThisWorkbook.Path & "\Agreement Template - CHERRY\"
End If
Set wd = GetObject(, "Word.Application")
If wd Is Nothing Then
Set wd = CreateObject("Word.Application")
End If
On Error GoTo 0
Set wdocSource = wd.Documents.Open(agreement_folder & Sheets("DATA").Range("AL" & x + 1).Value)
'Set wdocSource = wd.Documents.Open(agreement_folder & Sheets("DATA").Range("AL" & x).Value)
strWorkbookName = ThisWorkbook.Path & "\" & ThisWorkbook.Name
wdocSource.MailMerge.MainDocumentType = wdFormLetters
wdocSource.MailMerge.OpenDataSource _
Name:=strWorkbookName, _
AddToRecentFiles:=False, _
Revert:=False, _
Format:=wdOpenFormatAuto, _
Connection:="Data Source=" & strWorkbookName & ";Mode=Read", _
SQLStatement:="SELECT * FROM `DATA$`"
With wdocSource.MailMerge
.Destination = wdSendToNewDocument
.SuppressBlankLines = True
With .DataSource
.FirstRecord = x
.LastRecord = x
End With
.Execute Pause:=False
End With
Dim PathToSave As String
PathToSave = ThisWorkbook.Path & "\" & "pdf" & "\" & Sheets("DATA").Range("B2").Value & ".pdf"
If Dir(PathToSave, 0) <> vbNullString Then
With wd.FileDialog(FileDialogType:=msoFileDialogSaveAs)
If .Show = True Then
PathToSave = .SelectedItems(1)
End If
End With
End If
wd.ActiveDocument.ExportAsFixedFormat PathToSave, 17 'The constant for wdExportFormatPDF
'Sheets("Mail Merge").Select
wd.Visible = True
wdocSource.Close savechanges:=False
wd.ActiveDocument.Close savechanges:=False
Set wdocSource = Nothing
Set wd = Nothing
Next x
Sheets("Mail Merge").Range("D6").ClearContents
Sheets("Mail Merge").Range("D7").ClearContents
MsgBox "All necessary Documents created and are open for your review. Please save and send!", vbCritical
End Sub
Your code is non-trivial, so I'm not going to try to get it setup and working on my side. Instead, I'd suggest adding a Watch Window, and check the results. That should help you isolate the issue and quickly resolve it.
https://www.techonthenet.com/excel/macros/add_watch2016.php
Although error messages are sometimes misleading, it really should help you figure it out, or get close enough to post back with very specific information about what's going on there.

vArray values not clearing out from previous loop in VBA

I have some vArrays which are not clearing out. The purspose of the macro is to work on a raw data tab which has 30+ tabs, each tab holding information for a specific office, 001-New York, etc. The macro is supposed to select x number of tabs (based on a reference file), copy them and save them into a new workbook. The problem is that instead of copying and saving from the raw data file it save the reference file instead. A For...Next loop is used to determine which tabs/offices to select & copy from the raw data file. The varrays are inside the loop and contain the names of the offices. When the code encounters the vArray the varray values are not clearing out when the loop circles back around.
Example:
'For 1' reference a cell with value of "8" so it populates 8 different vArray values (offices in this case). 'For 2' has a reference number of 5 and is supposed to populate 5 vArray values. It does this correctly as I can see the 5 new values in the locals window under vArray (1) thru vArray (5), however, vArray 6 thru 8 are showing values of the previous loop instead of 'Empty'. The vArray values are not clearing out when the macro loops.
sMasterListWBName is the reference file which tells the macro which tabs to copy from the raw data file and where to move the newly created workbook. The sub is also copying, saving, and distributing the reference file instead of the raw data file for some iterations of the loop (secondary issue--I will try to refrain from splitting the thread topic).
Thanks in advance to anyone who tries to answer this question.
Option Explicit
Dim iYear As Integer, iMonth As Integer, iVer As Integer, icount As Integer, iCount2 As Integer
Dim iLetter As String, iReport As String
Dim sMonth As String, sDate As String, sVer As String, sAnswer As String
Dim sFolderName As String, sManagerInitials As String
Dim iManagerNumber As Integer, iManagerStart As Integer, iTabNumber As Integer, iTabStart As Integer
Dim sMasterListWBName As String, sConsolidatedWBName As String, sExists As String
Dim oSheet As Object, oDistList As Object
Dim vArray(300) As Variant
Dim wbDistList As Workbook
Dim wsAgentListSheet As Worksheet, wsMain As Worksheet
Dim rCell As Range, rCell2 As Range, rCellTotal As Range
Public sFINorAgent As String
Sub Agent_Distribute()
On Error Resume Next
iYear = frm_fin_rep_main_distribute.txt_year
iMonth = frm_fin_rep_main_distribute.txt_month
iVer = frm_fin_rep_main_distribute.txt_version
sMonth = Right("0" & iMonth, 2)
sDate = iYear & "." & sMonth
sVer = "V" & iVer
sAnswer = MsgBox("Is the following information correct?" & vbNewLine & vbNewLine & _
"Report - " & frm_fin_rep_main.sLetter & vbNewLine & _
"Year - " & iYear & vbNewLine & _
"Month - " & sMonth & vbNewLine & _
"Name - " & frm_fin_rep_main.sReport & vbNewLine & _
"Version - " & sVer, vbYesNo + vbInformation, "Please verify...")
If sAnswer <> vbYes Then
Exit Sub
End If
Unload frm_fin_rep_main_distribute
frm_agent.Hide
Form_Progress
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
sConsolidatedWBName = ActiveWorkbook.Name
sMasterListWBName = "Dist Master List Final.xls"
If Not IsFileOpen(sMasterListWBName) Then
Workbooks.Open FileName:= _
"W:\Addins\01 GL - Distribution\" & sMasterListWBName, Password:="password"
Workbooks(sConsolidatedWBName).Activate
End If
Set oDistList = Workbooks(sMasterListWBName).Worksheets("Agent")
With oDistList
iManagerNumber = .Range("ManNumber2") 'range value = 66
For iManagerStart = 2 To iManagerNumber '2 to 66
If .Range("A" & iManagerStart) = "x" Then
iTabNumber = .Range("E" & iManagerStart) 'E2 to E66
sFolderName = .Range("F" & iManagerStart) 'F2 to F66
sManagerInitials = .Range("G" & iManagerStart) 'G2 to G66
For iTabStart = 1 To iTabNumber
vArray(iTabStart) = .Range("G" & iManagerStart).Offset(0, iTabStart)
Next iTabStart
If iTabNumber = 1 Then
Sheets(vArray(1)).Select
Else
Sheets(vArray(1)).Select
For iTabStart = 2 To iTabNumber
Sheets(vArray(iTabStart)).Select False
Next iTabStart
End If
ActiveWindow.SelectedSheets.Copy
' *** the following code is optional, remove preceding apostrophes from the following four lines to enable password protection ***
'For Each oSheet In ActiveWorkbook.Sheets
'oSheet.Protect "password"
'oSheet.EnableSelection = xlNoSelection
'Next
ActiveWorkbook.SaveAs FileName:= _
"W:\Financials\" & iYear & "\" & sDate & "\Report to Distribute Electronically\Department Reports\" _
& sFolderName & "\Current Year Financials" & "\" & "Y" & ") " & iYear & "-" & sMonth & " Agent Report Card " & sVer & " - " & sManagerInitials & ".xls"
ActiveWorkbook.Close
End If
iPercent = iManagerStart / iManagerNumber * 95
Task_Progress (iPercent)
Next iManagerStart
End With
Workbooks(sMasterListWBName).Close False
Task_Progress (100)
Unload frm_progress
Set oDistList = Nothing
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
Message_Done
frm_agent.Show (vbModeless)
End Sub
I fixed it. I just added "Workbooks(sWbName).activate" at the end of the loop to make sure the focus is back on the raw data file. Now all files are saving in the correct format and location. Case closed unless someone has anything else to add. Maybe someone knows the reason the macro was losing sight of its active sheet (saving reference file instead of raw data file). Thank you.

Resources