I have a Userform that populates Textboxes with dates from a worksheet. The idea is to be able to edit the dates and save them back to the worksheet. The problem is the dates show up in American format, not European. I understand that I need to use code to force the date to show as European. So I have tried using this code
Dim LValue As String
LValue = Format(Date, "dd/mm/YYYY")
I then have a function to populate the form, where I want the correct date format to show
Sub PopulateForm()
Me.Location.Value = rngFound(1, 0).Value
Me.ID.Value = rngFound(1, 1).Value
Me.FirstName.Value = rngFound(1, 2).Value
Me.LastName.Value = rngFound(1, 3).Value
Me.Grade = rngFound(1, 4).Value
Me.ARLFam = rngFound(1, 8).Value
Me.ARLEvac = rngFound(1, 11).Value
Me.HRDFam = rngFound(1, 16).Value
Me.HRDEvac = rngFound(1, 19).Value
Me.CRDFam = rngFound(1, 24).Value
Me.CRDEvac = rngFound(1, 27).Value
Me.RSQFam = rngFound(1, 32).Value
Me.RSQEvac = rngFound(1, 35).Value
Me.COVFam = rngFound(1, 40).Value
Me.COVEvac = rngFound(1, 43).Value
Me.LSQFam = rngFound(1, 48).Value
Me.LSQEvac = rngFound(1, 51).Value
Me.HPCFam = rngFound(1, 56).Value
Me.HPCTrackFam = rngFound(1, 63).Value
Me.HPCEvac = rngFound(1, 59).Value
Me.KNBFam = rngFound(1, 67).Value
Me.KNBEvac = rngFound(1, 70).Value
End Sub
I haven't figured out where to place LValue in the sub routine for it to change the dates to the correct format. Am I on the right track? Or am I barking up the wrong tree?
Next, when I have changed the dates and save the changes to the worksheet, I encounter a new problem. The cells the dates go into are set up as dates, and other cells have formulas working off the information provided by the date cells. When I save the dates from the Userform, they show up in the correct cells, but all the other cells reading from the date cell now have the #Value error showing. This is the code used to save the new dates to the worksheet.
Private Sub EnterButton_Click()
Dim LR As Long
Dim replace As Long
Dim response As Long
Dim LValue As String
LValue = Format(Date, "dd/mm/YYYY")
If Me.ID.Value = "" Then
MsgBox "You have not entered an ID."
Me.ID.SetFocus
Exit Sub
End If
FindRecord (Val(Me.ID))
If Not rngFound Is Nothing Then
replace = MsgBox("This record already exists in this Database." & vbNewLine _
& "Replace?", vbYesNo)
If replace = vbYes Then
LR = rngFound.Row
Else
ClearForm
Me.ID.SetFocus
Exit Sub
End If
Else
LR = ws.Cells(Rows.Count, "A").End(xlUp).Row + 1
End If
With ws
.Cells(LR, 1).Value = Me.Location
.Cells(LR, 2).Value = Val(Me.ID)
.Cells(LR, 3).Value = Me.FirstName
.Cells(LR, 4).Value = Me.LastName
.Cells(LR, 5).Value = Me.Grade
.Cells(LR, 9).Value = Me.ARLFam
.Cells(LR, 12).Value = Me.ARLEvac
.Cells(LR, 17).Value = Me.HRDFam
.Cells(LR, 20).Value = Me.HRDEvac
.Cells(LR, 25).Value = Me.CRDFam
.Cells(LR, 28).Value = Me.CRDEvac
.Cells(LR, 33).Value = Me.RSQFam
.Cells(LR, 36).Value = Me.RSQEvac
.Cells(LR, 41).Value = Me.COVFam
.Cells(LR, 44).Value = Me.COVEvac
.Cells(LR, 49).Value = Me.LSQFam
.Cells(LR, 52).Value = Me.LSQEvac
.Cells(LR, 57).Value = Me.HPCFam
.Cells(LR, 64).Value = Me.HPCTrackFam
.Cells(LR, 60).Value = Me.HPCEvac
.Cells(LR, 68).Value = Me.KNBFam
.Cells(LR, 71).Value = Me.KNBEvac
End With
If replace = vbYes Then
MsgBox "The existing record on " & ws.Name & " row# " & rngFound.Row & " was overwitten"
Else
MsgBox "The record was written to " & ws.Name & " row# " & LR
End If
response = MsgBox("Do you want to enter another record?", _
vbYesNo)
If response = vbYes Then
ClearForm
Me.ID.SetFocus
Else
Unload Me
End If
End Sub
Is it because the date has been saved as text instead of a date? If so, how do I get it to save as a European date?
The following assumes that you have real dates in Excel (you can prove this for example by formatting a cell containing a date as General: It should display a number).
Background: dates are stored internally as numbers, the integer part
gives the Date-part, counting the number of days starting from 1.
January 1900. The fraction part is representing the time, 1/3 would be
8am (a third of the day)
A textbox in VBA contains always a String. When you want to write a date into the textbox and use code like tbStartDate = ActiveSheet.Cells("B2") and B2 contains a date, you are asking VBA to convert the date into a string. VBA will do so, but it has it's own rules for that and so you end up with a string that looks like an US date. Basically, you should always avoid that VBA does an automatic conversion for you. Instead, use a function for that: Format it the right function to convert a Date or a number into a string, you use it already correctly in the first 2 statements. To write the date into the textbox, you now write
tbStartDate = Format(ActiveSheet.Cells("B2"), "dd/mm/YYYY")
Now comes the tricky part: The user may change the date and you want to write it back to the cell. Again, you shouldn't let Excel do the conversion implicitly. The problem is that with a normal text box you cannot prevent that the user enters rubbish stuff (you might read Formatting MM/DD/YYYY dates in textbox in VBA).
But let's assume your user enters the date in the "correct" form: How do you convert a string into a date?
You often see the answer to use CDate that converts a string into a date, respecting the locale setting of the system. Fine, as long as all users have the same settings. But if you might have a user coming with a Laptop freshly imported from the US or that comes from any other part of the world, you have the same problem again: VBA will convert the date with wrong assumptions (eg changing the day- and month part).
Therefore I usually use a small custom function that splits the string and use the parts as parameters into another VBA function DateSerial. It will return 0 (=1.1.1900) if the input is complete nonsense, but doesn't check all invalid possibilities. A 13 as input is happily accepted (DateSerial, btw, accepts this also).
Function StrToDate(s As String) As Date
' Assumes input as dd/mm/yyyy or dd.mm.yyyy
Dim dateParts() As String
dateParts = Split(Replace(s, ".", "/"), "/") ' Will work with "." and "/"
If UBound(dateParts) <> 2 Then Exit Function
Dim yyyy As Long, mm As Long, dd As Long
dd = Val(dateParts(0))
mm = Val(dateParts(1))
yyyy = Val(dateParts(2))
If dd = 0 Or mm = 0 Or yyyy = 0 Then Exit Function
StrToDate = DateSerial(yyyy, mm, dd)
End Function
Now, writing the input back to the cell could be like
dim d as Date
d = StrToDate(tbStartdate)
if d > 0 then ActiveSheet.cells(B2) = d
you surely can change the current forat into an european one and here is some examples of how you can uses it :
Sub dates_et_heures()
'Now renvoie la date et l'heure en cours (07.02.2018 09:09:02)
date_test = Now()
'Renvoie : 07.02.18
Range("A1") = Format(date_test, "dd.mm.yy")
'Renvoie : mardi 7 février 2018
Range("A2") = Format(date_test, "dddd d mmmm yyyy")
'Renvoie : Mardi 7 Février 2018
Range("A3") = WorksheetFunction.Proper(Format(date_test, "dddd d mmmm yyyy"))
'Renvoie : mar. 07
Range("A4") = Format(date_test, "ddd dd")
'Renvoie : MAR 07
Range("A5") = "'" & Replace(UCase(Format(date_test, "ddd dd")), ".", "")
'Renvoie : FÉVRIER 2018
Range("A6") = UCase(Format(date_test, "mmmm yyyy"))
'Renvoie : 07.02.2018 09:09
Range("A7") = Format(date_test, "dd.mm.yyyy hh:mm")
'Renvoie : Le 7 février à 9h09'02''
Range("A8") = Format(date_test, "Le d mmmm à h\hmm'ss''")
'Renvoie : 9H09
Range("A9") = Format(date_test, "h\Hmm")
End Sub
I don't have the answer for the second part but i hope this could help too
I want to extract the time spent (weekly and monthly) in Outlook Calendar for different categories to extract reports.
I found this code with which I tried to play a bit with the goal to summarize the information for the whole calendar in an excel worksheet:
Sub ExportTimeSpentOnAppointmentsInEachColorCategory()
Dim objDictionary As Object
Dim objAppointments As Outlook.Items
Dim objAppointment As Outlook.AppointmentItem
Dim strCategory As String
Dim arrCategory As Variant
Dim varCategory As Variant
Dim objExcelApp As Excel.Application
Dim objExcelWorkbook As Excel.Workbook
Dim objExcelWorksheet As Excel.Worksheet
Dim arrKey As Variant
Dim arrItem As Variant
Dim i As Long
Dim nLastRow As Integer
Set objDictionary = CreateObject("Scripting.Dictionary")
Set objAppointments = Application.Session.PickFolder.Items
For Each objAppointment In objAppointments
arrCategory = Split(objAppointment.Categories, ",")
For Each varCategory In arrCategory
strCategory = Trim(varCategory)
If objDictionary.Exists(strCategory) Then
objDictionary.Item(strCategory) = objDictionary.Item(strCategory) + objAppointment.Duration
Else
objDictionary.Add strCategory, objAppointment.Duration
End If
Next
Next
'Create a new Excel workbook
Set objExcelApp = CreateObject("Excel.Application")
Set objExcelWorkbook = objExcelApp.Workbooks.Add
Set objExcelWorksheet = objExcelWorkbook.Sheets(1)
objExcelApp.Visible = True
objExcelWorkbook.Activate
With objExcelWorksheet
.Cells(1, 1) = "Color Category"
.Cells(1, 1).Font.Bold = True
.Cells(1, 1).Font.Size = 14
.Cells(1, 2) = "Total Time (min)"
.Cells(1, 2).Font.Bold = True
.Cells(1, 2).Font.Size = 14
End With
arrKey = objDictionary.Keys
arrItem = objDictionary.Items
For i = LBound(arrKey) To UBound(arrKey)
nLastRow = objExcelWorksheet.Range("A" & objExcelWorksheet.Rows.count).End(xlUp).Row + 1
objExcelWorksheet.Cells(nLastRow, 1) = arrKey(i)
objExcelWorksheet.Cells(nLastRow, 2) = arrItem(i)
Next
objExcelWorksheet.Columns("A:B").AutoFit
End Sub
How can I modify this code to generate this report for a given week or month (e.g. January 2020).
Part 1
If you do not know where to start with a problem, searching for blocks of code that might contain relevant code can be a good start. But you need to mine that code for useful nuggets. Simply trying to adapt that code to your problem is not going to work nor is asking someone else to adapt it.
What do you need to know? My initial list is:
How to find the calendar items for the period I wish to analyse?
How do I sort those calendar items by category?
How do I create a new Excel workbook or how do I update an existing workbook?
How do I arrange the information within the workbook in a useful manner?
This is not a complete list. For example: how does the user specify the required date range? I am not going to worry about such issues while I investigate the more difficult issues. Your code relates to need 2 so I will concentrate on need 1.
If there are any good Outlook VBA tutorials on calendars, I have not found them. Everything I know is the result of experimentation.
I created some appointments in the future, so they did not get confused with my real appointments. I used all the options within Create Appointment that were of interest to me. I created single appointments for different periods within same day, all day events, appointments that started on one day and ended on another. I created recurrent entries for every available period, for a fixed number of occurrences, until a given date or for ever. I then altered or deleted single occurrences.
I started with the object model for appointment items. I wrote a routine that looped down my appointment items outputting the properties that looked interesting. I learnt about the different type of appointment item and which properties went with which type. The routines below are the result of my experimentation.
The first thing I learnt was that my calendar was not where I expected it to be. This routine helps with that problem:
Sub CalendarDtls()
Dim InxFldrCrnt As Long
Dim InxStoreCrnt As Long
With Application.Session
Debug.Print "Store containing default calendar: " & .GetDefaultFolder(olFolderCalendar).Parent.Name
Debug.Print "Name of default calendar: " & .GetDefaultFolder(olFolderCalendar).Name
Debug.Print "Items in default calendar: " & .GetDefaultFolder(olFolderCalendar).Items.Count
For InxStoreCrnt = 1 To .Folders.Count
With .Folders(InxStoreCrnt)
For InxFldrCrnt = 1 To .Folders.Count
If LCase(Left$(.Folders(InxFldrCrnt).Name, 8)) = "calendar" Then
Debug.Print .Name & "\" & .Folders(InxFldrCrnt).Name & " Items: " & _
.Folders(InxFldrCrnt).Items.Count
Exit For
End If
Next
End With
Next
End With
End Sub
The above is an Outlook macro that displays details of the default calendar and of every calendar it can find.
When I started writing Outlook macros, I soon learnt how quickly the number of macros can grow and how difficult it can be to find the macro you want to look at today. I have lots of modules with meaningful names. My calendar experiments are in module ModCalendar. (Use F4 to access the Properties Window to rename modules.) I have no operational code in ModCalendar; operational code is held in modules with names like ModTaskName. I suggest you do something similar and place the above macro and the next one in a module named ModCalendar or something similar. Do not forget to include Option Explicit as the first statement.
Now consider this macro:
Sub DspCalendarItems()
' Create programmer-friendly list of items in selected calendar
' in desktop file Appointments.txt.
'Developed as aid to understanding Outlook calendars.
Dim ItemCrnt As Object
Dim ItemCrntClass As Long
Dim FileOut As Object
Dim FolderSrc As MAPIFolder
Dim Fso As FileSystemObject
Dim Path As String
Dim RecurrPattCrnt As RecurrencePattern
Path = CreateObject("WScript.Shell").specialfolders("Desktop")
Set Fso = CreateObject("Scripting.FileSystemObject")
Set FileOut = Fso.CreateTextFile(Path & "\Appointments.txt", True)
With Application.Session
'Set FolderSrc = .GetDefaultFolder(olFolderCalendar)
Set FolderSrc = .Folders("Outlook Data File").Folders("Calendar")
FileOut.WriteLine ("Number of items: " & FolderSrc.Items.Count)
For Each ItemCrnt In FolderSrc.Items
With ItemCrnt
' Occasionally I get syncronisation
' errors. This code avoids them.
ItemCrntClass = 0
On Error Resume Next
ItemCrntClass = .Class
On Error GoTo 0
' I have never found anything but appointments in
' Calendar but test just in case
If ItemCrntClass = olAppointment Then
Select Case .RecurrenceState
Case olApptException
FileOut.WriteLine ("Recurrence state is Exception")
If .AllDayEvent Then
FileOut.WriteLine ("All day " & Format(.Start, "ddd d mmm yy"))
Debug.Assert False
ElseIf Day(.Start) = Day(.End) Then
' Appointment starts and finishes on same day
If Format(.Start, "hh:mm") <> Format(.End, "hh:mm") Then
' Different start and end times on same day
FileOut.Write ("From " & Format(.Start, "hh:mm") & " to " & _
Format(.End, "hh:mm") & " on " & Format(.Start, "ddd d mmm yy"))
Debug.Assert False
Else
' Start and end time the same
Debug.Assert False
FileOut.Write ("At " & Format(.Start, "hh:mm") & " on " & Format(.Start, "ddd d mmm yy"))
End If
Else
' Different start and end dates.
FileOut.Write ("From " & Format(.Start, "hh:mm") & " on " & Format(.Start, "ddd d mmm yy") & " to " & _
Format(.End, "hh:mm") & " on " & Format(.End, "ddd d mmm yy"))
End If
Debug.Assert False
Case olApptMaster
Set RecurrPattCrnt = .GetRecurrencePattern
Debug.Assert Year(RecurrPattCrnt.PatternStartDate) = Year(.Start)
Debug.Assert Month(RecurrPattCrnt.PatternStartDate) = Month(.Start)
Debug.Assert Day(RecurrPattCrnt.PatternStartDate) = Day(.Start)
If .AllDayEvent Then
FileOut.Write ("All day ")
ElseIf Day(.Start) = Day(.End) Then
'Debug.Assert False
' Appointment starts and finishes on same day
If Format(.Start, "hh:mm") <> Format(.End, "hh:mm") Then
' Different start and end times on same day
FileOut.Write ("From " & Format(.Start, "hh:mm") & " to " & _
Format(.End, "hh:mm") & " ")
'Debug.Assert False
Else
' Start and end time the same
FileOut.Write ("At " & Format(.Start, "hh:mm") & " ")
Debug.Assert False
End If
ElseIf DateDiff("d", .Start, .End) = 1 And Format(.Start, "hh:mm") = "00:00" And _
Format(.End, "hh:mm") = "00:00" Then
FileOut.Write ("All day ")
'Debug.Assert False
Else
' Have not thought repeating multi-day appointments through
Debug.Assert False
FileOut.Write ("XXX From " & Format(.Start, "hh:mm") & " on " & Format(.Start, "ddd d mmm yy") & " to " & _
Format(.End, "hh:mm") & " on " & Format(.End, "ddd d mmm yy"))
End If
Select Case RecurrPattCrnt.RecurrenceType
Case olRecursDaily
'Debug.Assert False
FileOut.Write ("daily")
Case olRecursMonthly
Debug.Assert False
FileOut.Write ("monthly")
Case olRecursMonthNth
Debug.Assert False
FileOut.Write ("nth monthly")
Case olRecursWeekly
'Debug.Assert False
FileOut.Write ("weekly")
Case olRecursYearly
'Debug.Assert False
FileOut.Write ("yearly")
End Select ' RecurrPattCrnt.RecurrenceType
FileOut.Write (" from " & Format(RecurrPattCrnt.PatternStartDate, "ddd d mmm yy"))
If Year(RecurrPattCrnt.PatternEndDate) = 4500 Then
' For ever
'Debug.Assert False
Else
FileOut.Write (" to " & Format(RecurrPattCrnt.PatternEndDate, "ddd d mmm yy"))
'Debug.Assert False
End If
Case olApptNotRecurring
If .AllDayEvent Then
FileOut.Write ("All day " & Format(.Start, "ddd d mmm yy"))
'Debug.Assert False
ElseIf Day(.Start) = Day(.End) Then
' Appointment starts and finishes on same day
If Format(.Start, "hh:mm") <> Format(.End, "hh:mm") Then
' Different start and end times on same day
FileOut.Write ("From " & Format(.Start, "hh:mm") & " to " & _
Format(.End, "hh:mm") & " on " & Format(.Start, "ddd d mmm yy"))
'Debug.Assert False
Else
' Start and end time the same
FileOut.Write ("At " & Format(.Start, "hh:mm") & " on " & Format(.Start, "ddd d mmm yy"))
'Debug.Assert False
End If
Else
' Different start and end dates.
FileOut.Write ("From " & Format(.Start, "hh:mm") & " on " & Format(.Start, "ddd d mmm yy") & " to " & _
Format(.End, "hh:mm") & " on " & Format(.End, "ddd d mmm yy"))
'Debug.Assert False
End If
Case olApptOccurrence
FileOut.WriteLine ("Occurrence")
Debug.Assert False
Case Else
Debug.Print ("Unknown recurrence state " & .RecurrenceState)
Debug.Assert False
FileOut.WriteLine ("Unknown recurrence state " & .RecurrenceState)
End Select ' .RecurrenceState
If .Subject <> "" Then
FileOut.Write (" " & .Subject)
Else
FileOut.Write (" ""No subject""")
End If
If .Location <> "" Then
FileOut.Write (" at " & .Location)
Else
FileOut.Write (" at undefined location")
End If
FileOut.WriteLine ("")
If .Body <> "" Then
FileOut.WriteLine (" Body: " & .Body)
End If
End If ' ItemCrntClass = olAppointment
End With ' ItemCrnt
Next ItemCrnt
End With ' Application.Session
FileOut.Close
End Sub
Near the top of the above macro, you will find:
'Set FolderSrc = .GetDefaultFolder(olFolderCalendar)
Set FolderSrc = .Folders("Outlook Data File").Folders("Calendar")
If your appointments are in the default calendar, remove the quote from the first line and add one to the second. If your appointments are NOT in the default calendar, CalendarDtls() will have output something like:
Store containing default calendar: a.j.dallimore#MyIsp.com
Name of default calendar: Calendar (This computer only)
Items in default calendar: 0
a.j.dallimore#MyIsp.com #virginmedia.com\Calendar (This computer only) Items: 0
Outlook Data File\Calendar Items: 180
Find the row with a non-zero value for Items and copy the store name (Outlook Data File for me) and the folder name (Calendar for me) to the second line.
Run this macro and study the output. Where does it get the values it displays? Most appointment items have the same properties, but those properties will not have sensible values for inappropriate items. How has the macro decided what properties to display and what not to display? Add display of categories. I was not interested in categories so the macro does not display them.
This macro is basic. It does not touch complicated issues like exceptions. I believe it will be a good start of understanding how to identify the appointments that fall within the report period.
I have discovered a bug in the next macro I wish to share. I will add this macro when I have fixed the bug.
My total answer exceeds StackOverflow's limit of 30,000 characters so I have split the answer into two
Part 2
On more detailed checking, I found my second macro did not contain a bug; it was unfinished. My guess is I developed it far enough to discover what I needed to know and then abandoned it.
I have now finished that macro. It probably contains everything you need for the first issue on my list: How to find the calendar items for the period I wish to analyse?
Finding the calendar items you wish to analyse is trickier than you might expect. A one-off meeting will result in a single AppointmentItem in your calendar. That AppointmentItem will contain everything you need to know about the meeting. In particular, it contains properties Start and End which will allow a simple check against the report range. It is recurring appointments that are tricky.
Suppose I have regular team meetings on Tuesday and Thursday. I will go to my calendar and create an appointment for Thursday, 2 January 2020. I will enter the title, location, categories. I will then click [Recurrence]. I will click (Weekly) if it is not already selected as the Recurrence pattern. Thursday will be ticked. I will tick Tuesday. I will change the End date to Thursday, 31 December 2020. My calendar now shows appointments for every Tuesday and Thursday for the entire year. I have holidays booked for June, so I will delete the relevant entries. Later, I receive a message saying a particular meeting is to be half-an-hour later than normal and in a different meeting room. I will change the details for relevant day.
If a VBA macro looks at my calendar, it will find a single Master appointment for 2 January 2020. A Master appointment is one that recurs. The macro uses GetRecurrencePattern() to get the details of how the appointment recurs. The recurrence pattern also records all the exceptions.
The 100 or so entries on my calendar, have been generated from one AppointmentItem. To decide which of these entries are within the report period, my macro generates an array containing 5 and 2. It starts with Thursday 2 January 2020, then steps forward 5 days then 2 days then 5 days then 2 days then 5 days and so on until it is past the report period. The 5-day step takes it from Thursday to Tuesday. The 2-day step takes it from Tuesday to Thursday. The macro checks every date against the report period. If the date is within the report period, the macro checks for an exception. If there is no exception for the date, the macro adds a regular entry to the collection AppointToReport. An exception can be a delete of an occurrence or a change to an occurrence. For a delete, the macro does not add to the collection. For a change, it adds an entry based on the exception.
If that last paragraph was confusing, you will have to create some test appointments and step through the macro and study what it does.
I said at the beginning that I start with the object model for an AppointmentItem. This is a useful start, but it does not say which properties are used with which recurrence patterns. To discover that I use Watch. You will find [Watch Window] under [View] and [Add Watch] under [Debug]. I added the variables holding the AppointmentItem and the RecurrencePattern. This allowed me to understand how each property was used under different circumstances.
The macro below is an Excel macro. When you want to move data from Outlook to Excel, it can be difficult to decide whether to write the macro within Outlook or Excel since the code is very similar with both approaches. Outlook has a robust security system that does not like outside macros accessing its database, so the user must give permission at least once every 10 minutes. It does not worry about an Excel macro reading appointments, so that is not a consideration for you. For me, the biggest considerations are: (1) I find the Excel VBA development environment slightly easier than the Outlook development environment and (2) it is easier to share Excel macros with colleagues than Outlook macros.
If you really want an Outlook macro, you will have to recode the start of my macro.
I said earlier, the macro adds an entry to a collection for every event within the report range. When it has checked the entire calendar, it outputs the contents of that collection to a worksheet. For my test data, output is
The entries in the collection contain Start, End, Subject, Location and Categories. You can easily add more values if necessary. Note that the events are listed in the order added to the calendar. I added some appointments with categories first then appointments that used as many recurrence options as I thought I ought to test. If I understand correctly, you want to sum the total time per category so the sequence should not matter. You should test the macro will all AppointmentItem options you use.
I have left all my testing code within the macro but have commented it out. You can remove the quotes if you want to restore the output. I place Debug.Assert False at the top of every path through my code. When that path is executed, I comment the Debug.Assert False out. If you find a Debug.Assert False without a quote, it means the code below it has not been tested.
Option Explicit
Sub InvestigateCalendar()
' Outputs major properties of all calendar items within a calendar for a
' specified date range to desktop file "Calendar.txt". The objective is
' to better understand calendar itens and how they link.
' Requires reference to Microsoft Outlook nn.n Library
' where "nn.n" identifies the version of Office you are using.
' Specify date range to be reported on
Const DateReportStart As Date = #3/1/2020#
Const DateReportEnd As Date = #3/31/2020#
Dim AllDayEvent As Boolean
Dim AppointCrnt As Outlook.AppointmentItem
Dim AppointToReport As New Collection
Dim AppOutlook As New Outlook.Application
Dim CalItemClass As Long
Dim Categories As String
Dim DateAddInterval As String
Dim DateAddNumbers As Variant
Dim DateCrnt As Date
Dim DateEnd As Date
Dim DateStart As Date
Dim DayOfWeekMaskValues As Variant
Dim ExceptionAllDayEvent As Boolean
Dim ExceptionDateEnd As Date
Dim ExceptionDateStart As Date
Dim ExceptionLocation As String
Dim ExceptionNoneForDateCrnt As Boolean
Dim ExceptionSubject As String
Dim FldrCal As Outlook.Folder
Dim InxATR As Long ' Index into AppointToReport array
Dim InxDAN As Long ' Index into DateAddNumbers array
Dim InxDCrnt As Long ' Index into day of week arrays
Dim InxDEnd As Long ' End value for InxDCrnt
Dim InxDStart As Long ' Start value for InxDCrnt
Dim InxE As Long ' Index into exceptions
Dim InxFC As Long ' Index into Calendar folder
Dim IntervalNext As Long
Dim Location As String
Dim MaskCrnt As Long
Dim NumDaysInDayOfWeekMask As Long
Dim OccurrenceInRange As Boolean
Dim PathDesktop As String
Dim RecurrPattern As Outlook.RecurrencePattern
Dim RowCrnt As Long
Dim Subject As String
PathDesktop = CreateObject("WScript.Shell").SpecialFolders("Desktop")
' Use this Set if the calendar of interest is the default calendar.
'Set FldrCal = AppOutlook.Session.GetDefaultFolder(olFolderCalendar)
' Use this Set to access a named calendar
Set FldrCal = AppOutlook.Session.Folders("Outlook Data File").Folders("Calendar")
' Change above as necessary
'' Values returned by function Weekday for Sunday to Saturday
'WeekDayValues = VBA.Array(1, 2, 3, 4, 5, 6, 7)
' Values In DayOfWeekMask for Sunday to Saturday
DayOfWeekMaskValues = VBA.Array(1, 2, 4, 8, 16, 32, 64)
' 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
' Occasionally I get syncronisation errors. This code avoids them.
CalItemClass = -1
On Error Resume Next
CalItemClass = FldrCal.Items(InxFC).Class
On Error GoTo 0
' I have never found anything but appointment items in
' Calendar but test just in case
If CalItemClass = olAppointment Then
Set AppointCrnt = FldrCal.Items(InxFC)
With AppointCrnt
Select Case .RecurrenceState
Case olApptNotRecurring
'Debug.Assert False
'Debug.Assert .Subject <> "All day non-recurring"
'Debug.Assert .Subject <> "All day meeting"
If (.Start >= DateReportStart And .Start <= DateReportEnd) Or _
(.End >= DateReportStart And .End <= DateReportEnd) Then
'Debug.Assert False
' Either the start of the appointment is within the report range
' or the end of the appointment is with the report range or
' both start and end are within the report range
'AppointToReport.Add Array(.Start, .End, .Subject, .Location, .Categories)
AppointToReport.Add Array( _
CalcStartDateCrnt(.Start, .Start, .AllDayEvent), _
CalcEndDateCrnt(.Start, .End, .Start, .AllDayEvent), _
.Subject, .Location, .Categories)
Else
If .AllDayEvent Then
'Debug.Assert False
If DateAdd("d", 1, DateValue(.Start)) = DateValue(.End) Then
'Debug.Assert False
'Debug.Print "Non-recurring Out-of-range all day " & DateValue(.Start)
Else
Debug.Assert False
Debug.Print "Non-recurring Out-of-range all day" & _
DateValue(.Start) & "-" & DateValue(.End)
End If
Else
If DateValue(.Start) = DateValue(.End) Then
'Debug.Assert False
'Debug.Print "Non-recurring Out-of-range " & DateValue(.Start) & _
" " & TimeValue(.Start) & " - " & TimeValue(.End)
Else
'Debug.Assert False
'Debug.Print "Non-recurring Out-of-range " & .Start & " - " & .End
End If
End If
End If
Case olApptMaster
'Debug.Assert False
Set RecurrPattern = .GetRecurrencePattern()
DateStart = .Start
DateEnd = .End
AllDayEvent = .AllDayEvent
Location = .Location ' Record for recurring items
Subject = .Subject
'Debug.Assert Subject <> "Test recurring yearly 2 days"
Categories = .Categories
With RecurrPattern
' Not all properties have a meaningful value for all RecurrenceTypes
' but the value always appears to be of the correct data type.
'Debug.Print "Recurr Pattern " & .PatternStartDate & " - " & .PatternEndDate
'For InxE = 1 To .Exceptions.Count
' Debug.Print " Exception " & InxE & " to recurring item " & " for occurrence on " & _
' .Exceptions.Item(InxE).OriginalDate
'Next
'Debug.Assert .PatternStartDate <> #2/12/2020#
If .PatternStartDate >= DateReportEnd Or _
.PatternEndDate <= DateReportStart Then
' All occurrences outside report range
'Debug.Print " All occurences out-of-range"
Else
' For most recurrence types, there is a single interval. For weekly
' recurrences, the DayOfWeekMask there can be several intervals
If .RecurrenceType = olRecursYearly Then
'Debug.Assert False
' Set parameters for DateAdd
DateAddInterval = "yyyy"
' .Interval is the interval between occurrences in months
DateAddNumbers = VBA.Array(.Interval / 12)
ElseIf .RecurrenceType = olRecursYearNth Then
' I cannot discover how to create an appointment item with this
' RecurrenceType. Is it obsolete?
Debug.Assert False
DateAddInterval = "yyyy"
DateAddNumbers = VBA.Array(1) ' #### Fix if ever get this recurrence type
ElseIf .RecurrenceType = olRecursMonthly Then
'Debug.Assert False
DateAddInterval = "m"
DateAddNumbers = VBA.Array(.Interval)
ElseIf .RecurrenceType = olRecursMonthNth Then
' I cannot discover how to create an appointment item with this
' RecurrenceType. Is it obsolete?
Debug.Assert False
DateAddInterval = "m"
DateAddNumbers = VBA.Array(1) ' #### Fix if ever get this recurrence type
ElseIf .RecurrenceType = olRecursWeekly Then
'Debug.Assert False
DateAddInterval = "d" ' Step by days not weeks
MaskCrnt = 1
NumDaysInDayOfWeekMask = 0
' .DayOfWeekMask is sum of 64 for Saturday, 32 for Friday, ... 1 for Sunday
For InxDCrnt = 0 To 6 ' Sunday to Saturday
If (.DayOfWeekMask And MaskCrnt) <> 0 Then
NumDaysInDayOfWeekMask = NumDaysInDayOfWeekMask + 1
End If
MaskCrnt = MaskCrnt + MaskCrnt ' 1 -> 2 -> 4 ... -> 64
Next
If NumDaysInDayOfWeekMask = 1 Then
' Simple one day per week mask
ReDim DateAddNumbers(0 To 0)
DateAddNumbers(0) = .Interval * 7
Else
' .Interval is number of weeks between events
' If .Interval is 1, need one value per NumDaysInDayOfWeekMask
' If .Interval is >1, need one value per NumDaysInDayOfWeekMask+1
ReDim DateAddNumbers(0 To NumDaysInDayOfWeekMask + IIf(.Interval = 1, 0, 1) - 1)
' If meetings are Tuesday and Thursday with the first meeting on a
' Thursday, the intervals are 5, 2 and then 0 or 7 or 14 and so on
' according to the number of weeks between meetings.
' If meetings are Tuesday and Thursday with the first meeting on a
' Tuesday, the intervals are 2, 5 and then 0 or 7 or 14 and so on
' according to the number of weeks between meetings.
' In either case, the intervals then repeat until DateCrnt is after
' the report period.
' Starting the check for a date being within report period from the
' pattern start date will cause a delay if the pattern start date
' was in the remote past. If this happens, the start date for the
' check may have to be reviewed.
' Return value is 1 to 7. Want 0 to 6 for array index
InxDStart = Weekday(.PatternStartDate) - 1
' End day of week is day before start day of week
InxDEnd = IIf(InxDStart = 1, 7, InxDStart - 1)
InxDCrnt = InxDStart
IntervalNext = 1
InxDAN = 0
Do While True
' Start check at day of week after start date of week.
' Cycle back to zero after checking sixth day of week
InxDCrnt = IIf(InxDCrnt = 6, 0, InxDCrnt + 1)
If (DayOfWeekMaskValues(InxDCrnt) And .DayOfWeekMask) <> 0 Then
' This day is within day-of-week mask
DateAddNumbers(InxDAN) = IntervalNext
InxDAN = InxDAN + 1
IntervalNext = 0
End If
IntervalNext = IntervalNext + 1
If InxDCrnt = InxDEnd Then
Exit Do
End If
Loop
DateAddNumbers(InxDAN) = IntervalNext
InxDAN = InxDAN + 1
If .Interval > 1 Then
DateAddNumbers(InxDAN) = (.Interval - 1) * 7
End If
End If
ElseIf .RecurrenceType = olRecursDaily Then
Debug.Assert False
DateAddInterval = "d"
' .Interval is the interval between occurrences in days
DateAddNumbers = VBA.Array(.Interval)
End If
OccurrenceInRange = False ' Assume no occurrences in range until find otherwise
DateCrnt = .PatternStartDate
InxDAN = LBound(DateAddNumbers)
Do While True
If DateCrnt >= DateReportStart And DateCrnt <= DateReportEnd Then
' This occurrence within report range
OccurrenceInRange = True
'Debug.Print " In range " & DateCrnt
ExceptionNoneForDateCrnt = True
For InxE = 1 To .Exceptions.Count
With .Exceptions.Item(InxE)
If DateValue(.OriginalDate) = DateCrnt Then
' Have exception for this occurence
ExceptionNoneForDateCrnt = False
If .Deleted Then
' Occurence deleted.
' Nothing to output.
Else
' Occurence amended
With .AppointmentItem
ExceptionAllDayEvent = .AllDayEvent
ExceptionDateStart = .Start
ExceptionDateEnd = .End
ExceptionSubject = .Subject
ExceptionLocation = Location
' I cannot change the categories for an exception
End With
AppointToReport.Add Array( _
CalcStartDateCrnt(ExceptionDateStart, DateCrnt, _
ExceptionAllDayEvent), _
CalcEndDateCrnt(ExceptionDateStart, ExceptionDateEnd, _
DateCrnt, ExceptionAllDayEvent), _
ExceptionSubject, ExceptionLocation, Categories)
End If
Exit For
End If
End With
Next
If ExceptionNoneForDateCrnt Then
' No exception for this occurrence
AppointToReport.Add Array( _
CalcStartDateCrnt(DateStart, DateCrnt, AllDayEvent), _
CalcEndDateCrnt(DateStart, DateEnd, DateCrnt, AllDayEvent), _
Subject, Location, Categories)
End If
ElseIf DateCrnt >= DateReportEnd Then
' This occurrence is after end of report range
'Debug.Print " After range " & DateCrnt
Exit Do
Else
' This occurrence is before report range
'Debug.Print " Before range " & DateCrnt
End If
' Prepare for next repeat of loop
DateCrnt = DateAdd(DateAddInterval, DateAddNumbers(InxDAN), DateCrnt)
InxDAN = InxDAN + 1
If InxDAN > UBound(DateAddNumbers) Then
InxDAN = LBound(DateAddNumbers)
End If
Loop
End If
'If OccurrenceInRange Then
' 'Debug.Assert False
' Debug.Print " StartEndDate " & DateStart & " - " & DateEnd & _
' " " & IIf(AllDayEvent, "All", "Part") & " day"
' Debug.Print " PatternStartEndDate " & .PatternStartDate & " - " & .PatternEndDate
' Debug.Print " DayOfMonth " & .DayOfMonth & " " & "MonthOfYear " & .MonthOfYear
' Debug.Print " DayOfWeekMask " & .DayOfWeekMask
' Debug.Print " Instance " & .Instance & " " & "Interval " & .Interval
' Debug.Print " NoEndDate " & .NoEndDate
' Debug.Print " Occurrences " & .Occurrences
' Debug.Print " RecurrenceType " & .RecurrenceType & " ";
' Select Case .RecurrenceType
' Case olRecursYearly
' Debug.Print "Yearly"
' Case olRecursYearNth
' Debug.Print "YearNth"
' Case olRecursMonthly
' Debug.Print "Monthly"
' Case olRecursMonthNth
' Debug.Print "MonthNth"
' Case olRecursWeekly
' Debug.Print "Weekly"
' Case olRecursDaily
' Debug.Print "Daily"
' End Select
' Debug.Print " StartEndTime " & .StartTime & " - " & .EndTime
'End If
End With ' RecurrPattern
Case olApptException
Debug.Assert False
' Exceptions are linked to their Master calendar entry.
' I do not believe they exist at calendar entries
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
Case Else
Debug.Print "Unrecognised (" & .RecurrenceState & ")"
Debug.Assert False
End Select
End With ' AppointCrnt
End If ' CalItemClass = olAppointment
Next InxFC
' Output appointments to worksheet "Appointments"
With Worksheets("Appointments")
.Cells.EntireRow.Delete
' Create headings
With .Cells(1, 1)
.Value = "Start"
.NumberFormat = "dmmmyy"
End With
.Cells(1, 2).NumberFormat = "h:mm"
With .Range(.Cells(1, 1), .Cells(1, 2))
.Merge
.HorizontalAlignment = xlCenter
End With
With .Cells(1, 3)
.Value = "End"
.NumberFormat = "dmmmyy"
End With
.Cells(1, 4).NumberFormat = "h:mm"
With .Range(.Cells(1, 3), .Cells(1, 4))
.Merge
.HorizontalAlignment = xlCenter
End With
.Cells(1, 5).Value = "Subject"
.Cells(1, 6).Value = "Location"
.Cells(1, 7).Value = "Categories"
.Range(.Cells(1, 1), .Cells(1, 7)).Font.Bold = True
RowCrnt = 2
' Output data rows
For InxATR = 1 To AppointToReport.Count
DateStart = AppointToReport(InxATR)(0)
DateEnd = AppointToReport(InxATR)(1)
Subject = AppointToReport(InxATR)(2)
Location = AppointToReport(InxATR)(3)
Categories = AppointToReport(InxATR)(4)
.Cells(RowCrnt, 1).Value = DateValue(DateStart)
.Cells(RowCrnt, 2).Value = TimeValue(DateStart)
.Cells(RowCrnt, 3).Value = DateValue(DateEnd)
If TimeValue(DateEnd) <> 0 Then
.Cells(RowCrnt, 4).Value = TimeValue(DateEnd)
Else
.Cells(RowCrnt, 4).Value = #11:59:00 PM#
End If
.Cells(RowCrnt, 5).Value = Subject
.Cells(RowCrnt, 6).Value = Location
.Cells(RowCrnt, 7).Value = Categories
RowCrnt = RowCrnt + 1
Next
.Columns.AutoFit
End With
End Sub
Function CalcStartDateCrnt(ByVal DateStart As Date, ByVal DateCrnt As Date, _
ByVal AllDayEvent As Boolean) As Date
' Calculate the start date/time for an occurrence of a recurring event
' DateStart The start date/time of the first occurrence of the event
' DateCrnt The date of the current occurrence
' AllDayEvent True for an all day event
If AllDayEvent Then
CalcStartDateCrnt = DateSerial(Year(DateCrnt), Month(DateCrnt), Day(DateCrnt))
Else
CalcStartDateCrnt = DateSerial(Year(DateCrnt), Month(DateCrnt), Day(DateCrnt)) + _
TimeSerial(Hour(DateStart), Minute(DateStart), Second(DateStart))
End If
End Function
Function CalcEndDateCrnt(ByVal DateStart As Date, ByVal DateEnd As Date, _
ByVal DateCrnt As Date, ByVal AllDayEvent As Boolean) As Date
' Calculate the end date/time for an occurrence of a recurring event
' DateStart The start date/time of the first occurrence of the event
' DateEnd The end date/time of the first occurrence of the event
' DateCrnt The date of the current occurrence
' AllDayEvent True for an all day event
If AllDayEvent Then
' Times not required
If DateAdd("d", 1, DateValue(DateStart)) = DateValue(DateEnd) Then
' Single day event
CalcEndDateCrnt = DateSerial(Year(DateCrnt), Month(DateCrnt), Day(DateCrnt))
Else
' Multi-day event
CalcEndDateCrnt = DateSerial(Year(DateCrnt), Month(DateCrnt), _
Day(DateCrnt) + Day(DateEnd) - Day(DateStart) - 1)
End If
Else
CalcEndDateCrnt = DateSerial(Year(DateCrnt), Month(DateCrnt), _
Day(DateCrnt) + Day(DateEnd) - Day(DateStart)) + _
TimeSerial(Hour(DateEnd), Minute(DateEnd), Second(DateEnd))
End If
End Function
Really new to the Excel VBA.
Been working on one task and tried to piece all different elements into one working macro.
Here is my goal
as you can see on the picture,
there is a list of ID and names who reported their leave during the month.
I would like to translate into below format
start date/ end date /hours taken
1 Tried the code to capture start date, but failed to resume the loop to capture the end date.
Sub FindMatchingValue()
Dim i As Integer, intValueToFind As Integer
intValueToFind = 8
For i = 1 To 500 ' Revise the 500 to include all of your values
If Cells(2, i).Value = intValueToFind Then
MsgBox ("Found value on row " & i)
Cells(2, 35).Value = Cells(1, i) 'copy the start date to same row column 35
Exit Sub
End If
Next i
' This MsgBox will only show if the loop completes with no success
MsgBox ("Value not found in the range!")
End Sub
2 End date would be the last day for employee who took leave in consecutive days.
Really appreciate help from our community.
Following code will return you the first set of consecutive leave for first ID (Row 2) with start date, end date and hours taken:
Sub FindMatchingValue()
Dim i As Integer, intValueToFind As Integer, Found As Boolean, HoursTaken As Single
intValueToFind = 8
For i = 1 To 34 'Considering 34 is the max date column
If Found Then
If Cells(2, i).Value = "" Then
MsgBox ("Last consecutive column " & i - 1)
Cells(2, 36).Value = Cells(1, i - 1) 'copy the end date to same row column 36
Cells(2, 37).Value = HoursTaken 'Hours taken to same row column 37
Found = False
Exit Sub 'Skip after first set of leave
Else
HoursTaken = HoursTaken + Cells(2, i)
End If
ElseIf Cells(2, i).Value = intValueToFind Then
MsgBox ("Found value on column " & i)
Cells(2, 35).Value = Cells(1, i) 'copy the start date to same row column 35
Found = True
HoursTaken = Cells(2, i)
End If
Next i
'This MsgBox will only show if the loop completes with no success
MsgBox ("Value not found in the range!")
End Sub
You have to think more on how will you capture the next sets of leave for the same person and run it for entire set of data row. Hope this will be help in solving your problem.
so i have Sheet1 that is use to contain the list of my inventory data. what i want to do is in another sheet(Sheet2). i can search my Sheet1 data and display the data there ( for example when i type cheetos, only the cheetos item got display ). Help me guys, using VBA is okay or other method is also fine.
If your results don't have to be on a different sheet, you could just convert your data to a Table. Select Cells A1:D8 and click on Insert -> Table. Make sure "My table has headers" is clicked and voila!
Once formatted as a table, you can filter Product ID however you need.
If you do need to show these results in another sheet, VBA would be my go-to solution. Maybe something like this:
Public Sub FilterResults()
Dim findText As String
Dim lastRow As Long
Dim foundRow As Long
Dim i As Long
'If there's nothing to search for, then just stop the sub
findText = LCase(Worksheets("Sheet2").Range("D4"))
If findText = "" Then Exit Sub
'Clear any old search results
lastRow = Worksheets("Sheet2").Cells(Rows.Count, 4).End(xlUp).Row
If lastRow > 5 Then
For i = 6 To lastRow
Worksheets("Sheet2").Range("C" & i).ClearContents
Worksheets("Sheet2").Range("D" & i).ClearContents
Worksheets("Sheet2").Range("E" & i).ClearContents
Worksheets("Sheet2").Range("F" & i).ClearContents
Next i
End If
'Start looking for new results
lastRow = Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
foundRow = 6
For i = 2 To lastRow
If InStr(1, LCase(Worksheets("Sheet1").Range("B" & i)), findText) <> 0 Then
Worksheets("Sheet2").Range("C" & foundRow) = Worksheets("Sheet1").Range("A" & i)
Worksheets("Sheet2").Range("D" & foundRow) = Worksheets("Sheet1").Range("B" & i)
Worksheets("Sheet2").Range("E" & foundRow) = Worksheets("Sheet1").Range("C" & i)
Worksheets("Sheet2").Range("F" & foundRow) = Worksheets("Sheet1").Range("D" & i)
foundRow = foundRow + 1
End If
Next i
'If no results were found, then open a pop-up that notifies the user
If foundRow = 6 Then MsgBox "No Results Found", vbCritical + vbOKOnly
End Sub
I would recommend avoiding VBA for this process as it can be done easily with excel's functions. If you would like to do it via VBA one could just loop through the list of products and find a key word, adding it to an array if the "Cheetos" is contained in the specific cell value using a wildcard like so:
This could be modified to run upon the change of the D4 cell if needed, and of course some modifications could be done to ensure that formatting etc can be done to your liking.
Sub test()
Dim wb As Workbook
Dim rng As Range, cell As Range
Dim s_key As String, s_find() As String
Dim i As Long
Set wb = Application.ThisWorkbook
Set rng = wb.Sheets("Sheet1").Range("B2:B8")
s_key = wb.Sheets("Sheet2").Range("D4").Value
wb.sheets("Sheet2").Range("C6:F9999").clearcontents
i = 0
For Each cell In rng
If cell.Value Like "*" & s_key & "*" Then
ReDim Preserve s_find(3, i)
s_find(0, i) = cell.Offset(0, -1).Value
s_find(1, i) = cell.Value
s_find(2, i) = cell.Offset(0, 1).Value
s_find(3, i) = cell.Offset(0, 2).Value
i = i + 1
End If
Next cell
wb.Sheets("Sheet2").Range("C6:F" & 5 + i).Value = Application.WorksheetFunction.Transpose(s_find)
End Sub