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.
1. Select a P6 calendar and a year whose monthly calendars are to be created
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 fileP6-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 demonstration6. 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