Create Project calendar based on the Primavera P6 Xer file using Excel VBA and SQL

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.

Project calendar

1. Select a P6 calendar and a year whose monthly calendars are to be created

Calendar Userform

1.1 Prepopulate the Userform with all the project calendars

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

1.2 Select a year for the corresponding monthly calendars to run the program

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

2. Create project monthly project calendar of the selected year

2.1 Parse the data of the selected calendar in the data table "CALENDAR"

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

2.2 Create the monthly calendars of the selected year

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

3. Data Processing using SQL Connection

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

4. Project planning data using the Xer file

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
P6-Project activity data table based on p6 xer file

5. Download an application package designed for Xer data manipulation

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 demonstration

6. Loading Excel Add-in

It 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