This page discusses how to create the project calendar incorporating project holidays into it. The project calendar is created in line with the Primavera P6 calendar to be selected. It is presumed that the project Xer file has been made available and parsed to every distinct data table. How to read and parse the xer file is discussed on the page Xer (P6 text file) written to Excel.
Sub PRAP_Calendar() Set wba = Workbooks("PRAP.xlam"): Set wsa = wba.Worksheets("xer") Set wb = ActiveWorkbook: Set ws = wb.ActiveSheet If wsa.Cells(1, 1) <> "" Then Filename = wsa.Cells(1, 1).Value Else Call Choose_XerFile End If Dateformat = DateformatProcedure Call ImportXer 'run import and create data tables If wsa.Cells(2, 1) <> "" Then ProjectID = wsa.Cells(2, 1).Value ProjectName = wsa.Cells(2, 2).Value Else MsgBox "A project to work with is required. Select an Icon ""Project Summary"" on the Ribbon." Exit Sub End If If wsa.Cells(3, 1) <> "" Then StartDate = wsa.Cells(3, 1).Value EndDate = wsa.Cells(3, 2).Value Else MsgBox "A project schedule is required. Select an Icon ""Project Summary"" on the Ribbon." Exit Sub End If Dim StartYear As Long, EndYear As Long, YearList() As Variant StartYear = Format(Year(StartDate), "0") EndYear = Format(Year(EndDate), "0") Erase YearList ReDim Preserve YearList(EndYear - StartYear + 1) For i = 1 To EndYear - StartYear + 1 YearList(i) = StartYear + i - 1 Next i '***************************************** ' List all the Project calendar listing '***************************************** Dim iclndr_id As Integer, iclndr_name As Integer, iproj_id As Integer r = UBound(myTable(iCALENDAR)) c = UBound(myTable(iCALENDAR), 2) For i = 1 To c Select Case myTable(iCALENDAR)(2, i) Case "clndr_id" iclndr_id = i Case "clndr_name" iclndr_name = i Case "proj_id" iproj_id = i End Select Next i With uf_calendar .Label4.Caption = "Xer File: " & Filename .Label5.Caption = "Project ID: " & ProjectID .Label6.Caption = "Project Name: " & ProjectName .Label8.Caption = Format(StartDate, Dateformat) .Label10.Caption = Format(EndDate, Dateformat) .ComboBox1.List = YearList With .ListBox1 .ColumnCount = 2 .ColumnWidths = "100 pt;250 pt" .Width = 377 .MultiSelect = fmMultiSelectSingle For i = 1 To (UBound(myTable(iCALENDAR)) - 2) .AddItem .List(.ListCount - 1, 0) = myTable(iCALENDAR)(2 + i, iclndr_id) .List(.ListCount - 1, 1) = myTable(iCALENDAR)(2 + i, iclndr_name) Next i End With .OptionButton1.Value = True .CommandButton1.Enabled = False .Show vbModeless End With
Private Sub CommandButton1_Click() Dim i As Long, CalendarID As String With ListBox1 For i = 0 To .ListCount - 1 If .Selected(i) = True Then CalendarID = .List(i, 0) End If Next i End With Call Calendar_Data(CalendarID) Call Calendar_Gen End Sub
Parse the selected project calendar data and rearrange the data. The separator is "(0||".
Sub Calendar_Data(CalendarID) ' Parse clndr_data in the data table "CALENDAR" Dim iclndr_id As Integer, iclndr_data As Integer Dim CalendarData As String Dim a As Variant, S As Date, F As Date For i = 1 To UBound(myTable(iCALENDAR), 2) Select Case myTable(iCALENDAR)(2, i) Case "clndr_id" iclndr_id = i Case "clndr_data" iclndr_data = i End Select Next i For i = 3 To UBound(myTable(iCALENDAR)) If myTable(iCALENDAR)(i, iclndr_id) = CalendarID Then CalendarData = myTable(iCALENDAR)(i, iclndr_data) End If Next i a = Split(CalendarData, "(0||") Dim myTemp() As Variant, Y As Long, z As Long Erase myTemp ReDim Preserve myTemp(UBound(a) + 1, 4) myTemp(1, 1) = "clndr_id": myTemp(1, 2) = "type": myTemp(1, 3) = "Date" myTemp(1, 4) = "Hours" For j = 2 To UBound(a) + 1 myTemp(j, 1) = CalendarID Next j For j = 2 To UBound(a) If InStr(a(j), "DaysOfWeek") <> 0 Then myTemp(1 + j, 2) = "DaysOfWeek" ElseIf InStr(a(j), "Exceptions") <> 0 Then myTemp(1 + j, 2) = "Exceptions" End If If myTemp(1 + j, 2) = "" Then myTemp(1 + j, 2) = myTemp(j, 2) End If If (myTemp(1 + j, 2) = "DaysOfWeek" And InStr(Left(a(j), 3), "()") <> 0) Then myTemp(1 + j, 3) = Left(a(j), 1) End If If (myTemp(1 + j, 2) = "Exceptions" And InStr(a(j), "d|") <> 0) Then myTemp(1 + j, 3) = Mid(a(j), InStr(a(j), "d|") + 2, 5) End If If InStr(a(j), "s|") <> 0 Then S = TimeValue(Mid(a(j), InStr(a(j), "s|") + 2, 4)) F = TimeValue(Mid(a(j), InStr(a(j), "f|") + 2, 4)) If S = F Then myTemp(1 + j, 4) = 24 Else myTemp(1 + j, 4) = Abs((F - S) - (S > F)) * 24 End If End If If myTemp(1 + j, 3) = "" And myTemp(1 + j, 2) = myTemp(j, 2) And _ myTemp(1 + j, 1) = myTemp(j, 1) And _ InStr(a(j), "VIEW(ShowTotal|Y)") = 0 Then myTemp(1 + j, 3) = myTemp(j, 3) End If Next j For i = 2 To UBound(a) If myTemp(i, 3) = "" Or (myTemp(i, 4) = "" And myTemp(i, 3) = myTemp(i + 1, 3)) Then For j = 1 To 4 myTemp(i, j) = "" Next j End If Next i n = 0 For i = 2 To UBound(a) + 1 If myTemp(i, 1) <> "" Then n = n + 1 End If Next i Dim myTemp1() As Variant Erase myTemp1 ReDim Preserve myTemp1(n + 1, 4) n = 0 myTemp1(1, 1) = "myTemp1" On Error Resume Next For i = 1 To UBound(myTemp) If myTemp(i, 1) <> "" Then n = n + 1 For j = 1 To 4 myTemp1(n + 1, j) = myTemp(i, j) Next j End If Next i On Error GoTo 0 Erase myTemp Dim strsql As String Call AddWorksheet(myTemp1(1, 1), myTemp1) strsql = "SELECT [clndr_id],[type],[Date],sum([Hours])from [myTemp1$] " & _ "GROUP BY [clndr_id],[type],[Date]" myCalendar = QueryResultArray(strsql) Erase myTemp1 Call DeleteWorksheet("myTemp1") End Sub
The calendar data is stored in myCalendar(). Weekday() function is used to match with weekday of each month date. Highlight non-working days and project holidays defined as Exception in the project calendar.
Sub Calendar_Gen() Dim i As Long, j As Long, n As Long, Y As Integer, M As Variant, r As Long, c As Long Dim ii As Long, jj As Long Dim MonthNames As Variant Dim RefDate As Date Dim myArray(6, 7) As Variant With Application .ScreenUpdating = False .DisplayAlerts = False .EnableEvents = False End With On Error Resume Next Set wb = ActiveWorkbook Set ws = wb.Worksheets("P6 Calendar") n = wb.Worksheets.Count If Err <> 0 Then Set ws = wb.Worksheets.Add(After:=wb.Worksheets(n)) ws.Name = "P6 Calendar" End If On Error GoTo 0 Y = CLng(uf_calendar.ComboBox1.Value) MonthNames = Array("Jan", "Feb", "Mar", "Apr", "May", _ "Jun", "Jul", "Aug", "Sep", "Oct", "Nov", "Dec") With ws.Cells .ClearContents .MergeCells = False .Borders.LineStyle = xlNone .Interior.Color = xlNone .Font.Bold = False .Font.Size = 11 .Font.Color = RGB(0, 0, 0) .RowHeight = 15: .ColumnWidth = 8.11 .HorizontalAlignment = xlCenter End With With ws M = 0 For ii = 1 To 4 DoEvents r = (ii - 1) * 15 + 1 For jj = 1 To 3 c = (jj - 1) * 8 + 1 M = M + 1 .Cells(r, c).Value = DateSerial(Y, M, 1) RefDate = DateSerial(Y, M, 1) Select Case True Case uf_calendar.OptionButton1.Value With .Cells(r, c).Offset(1, 0).Resize(1, 7) .Value = Array("Sun", "Mon", "Tue", "Wed", "Thu", "Fri", _ "Sat") End With For i = 1 To 6 For j = 1 To 7 myArray(i, j) = RefDate + 7 * (i - 1) + (j - 1) _ - (Weekday(RefDate) - 1) If Month(RefDate) <> Month(myArray(i, j)) Then myArray(i, j) = vbNullString End If Next j Next i Case uf_calendar.OptionButton2.Value With .Cells(r, c).Offset(1, 0).Resize(1, 7) .Value = Array("Mon", "Tue", "Wed", "Thu", "Fri", "Sat", "Sun") End With For i = 1 To 6 For j = 1 To 7 myArray(i, j) = RefDate + 7 * (i - 1) + (j - 1) _ - (Weekday(RefDate) + 5) If Month(RefDate) <> Month(myArray(i, j)) Then myArray(i, j) = vbNullString End If Next j Next i End Select With .Cells(r + 2, c).Resize(6, 7) .Value = myArray .NumberFormat = "d" .EntireColumn.ColumnWidth = 15 End With 'Calendar Formatting, Row below date row is added. 'Last row without date data is removed. For i = 6 To 1 Step -1 .Cells(r + 2 + i, c).Resize(1, 7).Insert shift:=xlDown Next i 'Added rows with more space Dim rs As Long For i = 1 To 6 .Cells(r + 1 + 2 * i, c).RowHeight = 55 ' Next 'Bordering With .Cells(r, c).Resize(14, 7).Borders .Weight = xlThin .ThemeColor = 1 .TintAndShade = -0.35 End With 'Top level formatting With .Cells(r, c) .NumberFormat = "MMMM-YY" .Resize(1, 7).MergeCells = True .Font.Size = 14 .RowHeight = 20 End With With .Cells(r, c).Resize(2, 7) .Font.Bold = True .HorizontalAlignment = xlCenter .VerticalAlignment = xlCenter .Interior.Color = RGB(200, 200, 200) End With Next jj Next ii Dim CalRange As Range, mycell As Range Set CalRange = Union(.Range("A3:W3"), .Range("A5:W5"), .Range("A7:W7"), .Range("A9:W9"), .Range("A11:W11"), .Range("A13:W13") _ , .Range("A18:W18"), .Range("A20:W20"), .Range("A22:W22"), .Range("A24:W24"), .Range("A26:W26"), .Range("A28:W28") _ , .Range("A33:W33"), .Range("A35:W35"), .Range("A37:W37"), .Range("A39:W39"), .Range("A41:W41"), .Range("A43:W43") _ , .Range("A48:W48"), .Range("A50:W50"), .Range("A52:W52"), .Range("A54:W54"), .Range("A56:W56"), .Range("A58:W58")) End With For Each mycell In CalRange If mycell <> "" Then Select Case Weekday(mycell.Value) Case 1 For i = 1 To UBound(myCalendar) If myCalendar(i, 2) = "DaysOfWeek" And myCalendar(i, 3) = 1 Then Call Calformat(mycell, myCalendar(i, 4)) Exit For End If Next i Case 2 For i = 1 To UBound(myCalendar) If myCalendar(i, 2) = "DaysOfWeek" And myCalendar(i, 3) = 2 Then Call Calformat(mycell, myCalendar(i, 4)) Exit For End If Next i Case 3 For i = 1 To UBound(myCalendar) If myCalendar(i, 2) = "DaysOfWeek" And myCalendar(i, 3) = 3 Then Call Calformat(mycell, myCalendar(i, 4)) Exit For End If Next i Case 4 For i = 1 To UBound(myCalendar) If myCalendar(i, 2) = "DaysOfWeek" And myCalendar(i, 3) = 4 Then Call Calformat(mycell, myCalendar(i, 4)) Exit For End If Next i Case 5 For i = 1 To UBound(myCalendar) If myCalendar(i, 2) = "DaysOfWeek" And myCalendar(i, 3) = 5 Then Call Calformat(mycell, myCalendar(i, 4)) Exit For End If Next i Case 6 For i = 1 To UBound(myCalendar) If myCalendar(i, 2) = "DaysOfWeek" And myCalendar(i, 3) = 6 Then Call Calformat(mycell, myCalendar(i, 4)) Exit For End If Next i Case 7 For i = 1 To UBound(myCalendar) If myCalendar(i, 2) = "DaysOfWeek" And myCalendar(i, 3) = 7 Then Call Calformat(mycell, myCalendar(i, 4)) Exit For End If Next i End Select End If Next For Each mycell In CalRange If mycell <> "" Then For i = 1 To UBound(myCalendar) If myCalendar(i, 2) = "Exceptions" And CDate(mycell.Value) = CDate(myCalendar(i, 3)) Then Call Calformat(mycell, myCalendar(i, 4)) Exit For End If Next i End If Next ActiveWindow.DisplayGridlines = False Application.EnableEvents = True MsgBox "Project calendar is generated." End Sub Sub Calformat(mycell, mycal) If IsNull(mycal) Then mycell.Interior.Color = RGB(255, 200, 170) mycell.Offset(1, 0).Value = "" ElseIf mycal > 0 Then mycell.Interior.Color = RGB(255, 255, 255) With mycell.Offset(1, 0) .Value = mycal & " hrs" .HorizontalAlignment = xlRight .VerticalAlignment = xlBottom .Font.Color = RGB(100, 100, 100) End With End If End Sub
Data processing requires mutiple data tables
and thus data processing with VBA programming language (array, looping and so on) requires extensive coding effort.
SQL can make the coding work much simpler using SQL Connection for Excel VBA than VBA programming.
This is possible by using the ADO connect to Excel driver or Access Database. The current ADO connect is based on the ADO connect to Access Database and late binding to the needed object libraries.
Sql query string is passed to the Function QueryResultArray() below to handle the SQL query like Microsoft Access or SQL server.
Sub ExampleSQL() strsql = "SELECT [clndr_id],[type],[Date],sum([Hours])from [myTemp1$] " & _ "GROUP BY [clndr_id],[type],[Date]" myCalendar = QueryResultArray(strsql) End Sub
Function QueryResultArray(sqlquery As String) As Variant '4. Microsoft.ACE.OLEDB-Late Binding Dim rst As Object Dim MyConnect As String Dim arrResults() As Variant, i As Long, n As Long DoEvents Set rst = CreateObject("ADODB.Recordset") MyConnect = "Provider=Microsoft.ACE.OLEDB.12.0;" & _ "Data Source=" & ActiveWorkbook.FullName & ";" & _ "Extended Properties=Excel 12.0" With rst .Open sqlquery, MyConnect .MoveFirst n = 0 Do Until .EOF n = n + 1 .MoveNext Loop Erase arrResults ReDim Preserve arrResults(n, .Fields.Count) .MoveFirst n = 0 Do Until .EOF n = n + 1 For i = 1 To .Fields.Count On Error Resume Next arrResults(n, i) = .Fields(i - 1) On Error GoTo 0 Next i .MoveNext Loop End With QueryResultArray = arrResults Set rst = Nothing MyConnect = "" End Function
On top of this page, the following pages can help you read/parse Xer file to Excel, create project summary, and consolidate project data. To do so, visit the pages below.
Xer (P6 text file) written to Excel P6-project summary based on p6 xer file
The downloadable application covers four(4) pages:Read/parse Xer data, P6 summary, P6 data table, and P6 Calendar.
Download Excel add-in and a workbook for demonstrationIt is necessary to install the downloaded Excel Add-in. To do so, visit the page below.
Create and load Excel Add-in
Modified on:3-November-2019
Dated on: 4-October-2019