CODEWITHSUNDEEP
vbams-project
Asp1re
Asp1re

Reputation: 353

How to export Working Time from MS Project to MS Excel?

I have a Project file that contains products that are configured on different workstations that have working hours / day. I managed to export the Holiday/Exceptions through VBA/Macro but I need the working hours ex. 06:30 AM to 14:30 PM for each workstation. In the project file I can view this information by clicking Project > Change Working Time - at this point I can select the workstation from the dropdown For calendar and there is a mini calendar where I can select a specific date - by clicking a date I can see the working hours on that day. I can also view this information by clicking the Details button.

Is there any in built function that I can use to extract that data? Or is it possible to get that information via macro? I need this data to be extracted in a Excel file so I can later import it into an SQL database.

The code that I use to extract the holidays/exceptions is the following(I copy pasted from a google search, it is not written by me, I am new to MS Project/VBA):

Option Explicit
Sub CalendarWeekdays()

Dim MyXL As Object
Set MyXL = CreateObject("Excel.Application")
Dim i As Integer, j As Integer
Dim E As Exception
Dim R As Resource
Dim xlRng

'open Excel, define workbook, and set column headers
MyXL.Workbooks.Add
MyXL.Visible = True
MyXL.ActiveWorkbook.worksheets.Add.Name = "Exception Report"
MyXL.ActiveWorkbook.worksheets("Exception Report").Activate
Set xlRng = MyXL.activesheet.Range("A1")
xlRng.Range("A1") = "Proj Cal Holidays"
xlRng.Range("B1") = "Start Date"
xlRng.Range("C1") = "Finish Date"
xlRng.Range("E1") = "Res Name"
xlRng.Range("F1") = "Res Base Cal"
xlRng.Range("G1") = "Base Cal Excep"
xlRng.Range("H1") = "Start Date"
xlRng.Range("I1") = "Finish Date"
xlRng.Range("K1") = "Resource Name"
xlRng.Range("L1") = "Res Excep"
xlRng.Range("M1") = "Start Date"
xlRng.Range("N1") = "Finish Date"

'First gather and export Project calendar exceptions
i = 2
If ActiveProject.Calendar.Exceptions.Count > 0 Then
    For Each E In ActiveProject.Calendar.Exceptions
        xlRng.Range("A" & i) = E.Name
        xlRng.Range("B" & i) = E.Start
        xlRng.Range("C" & i) = E.Finish
        i = i + 1
    Next
End If

'Next, gather and export resource base calendar exceptions along with
'   resource calendar exceptions
i = 2
For Each R In ActiveProject.Resources
    If Not R Is Nothing Then
        j = i
        If R.Type = pjResourceTypeWork Then
                For Each E In R.Calendar.BaseCalendar.Exceptions
                    xlRng.Range("E" & i) = R.Name
                    xlRng.Range("F" & i) = R.Calendar.BaseCalendar.Name
                    xlRng.Range("G" & i) = E.Name
                    xlRng.Range("H" & i) = E.Start
                    xlRng.Range("I" & i) = E.Finish
                    i = i + 1
                Next E
                For Each E In R.Calendar.Exceptions
                    xlRng.Range("K" & j) = R.Name
                    xlRng.Range("L" & j) = E.Name
                    xlRng.Range("M" & j) = E.Start
                    xlRng.Range("N" & j) = E.Finish
                    j = j + 1
                Next E
        End If
    End If
Next R
MyXL.ActiveWorkbook.worksheets("Exception Report").Columns("A:N").AutoFit
End Sub

UPDATE:

I managed to get the hours from the Exceptions and Weekdays! Here is my complete working VBA code:

Option Explicit
Sub CalendarWeekdays()

Dim MyXL As Object
Set MyXL = CreateObject("Excel.Application")
Dim i As Integer
Dim R As Resource
Dim d As PjWeekday
Dim E As Exception
Dim xlRng
MyXL.Workbooks.Add
MyXL.Visible = True

' I. EXCEPTIONS

' a. Export resource base calendar exceptions along with
'    resource calendar exceptions
MyXL.ActiveWorkbook.Worksheets("Sheet1").Activate
MyXL.activesheet.Name = "Base & Resource Exceptions"
Set xlRng = MyXL.activesheet.Range("A1")
MyXL.activesheet.Range("A1:K1").Font.Bold = True

xlRng.Range("A1") = "Resource"
xlRng.Range("B1") = "Resource Base Name"
xlRng.Range("C1") = "Name"
xlRng.Range("D1") = "Start"
xlRng.Range("E1") = "Finish"
xlRng.Range("F1") = "S1 Start"
xlRng.Range("G1") = "S1 Finish"
xlRng.Range("H1") = "S2 Start"
xlRng.Range("I1") = "S2 Finish"
xlRng.Range("J1") = "S3 Start"
xlRng.Range("K1") = "S3 Finish"

i = 2
For Each R In ActiveProject.Resources
    If Not R Is Nothing Then
        If R.Type = pjResourceTypeWork Then
                For Each E In R.Calendar.Exceptions
                    xlRng.Range("A" & i) = R.Name
                    xlRng.Range("B" & i) = R.Calendar.BaseCalendar.Name
                    xlRng.Range("C" & i) = E.Name
                    xlRng.Range("D" & i) = E.Start
                    xlRng.Range("E" & i) = E.Finish
                    xlRng.Range("F" & i) = E.Shift1.Start
                    xlRng.Range("G" & i) = E.Shift1.Finish
                    xlRng.Range("H" & i) = E.Shift2.Start
                    xlRng.Range("I" & i) = E.Shift2.Finish
                    xlRng.Range("J" & i) = E.Shift3.Start
                    xlRng.Range("K" & i) = E.Shift3.Finish
                    i = i + 1
                Next E
        End If
    End If
Next R

' b. Export project calendar exceptions
MyXL.ActiveWorkbook.Worksheets.Add.Name = "Project Exceptions"
MyXL.ActiveWorkbook.Worksheets("Project Exceptions").Activate
Set xlRng = MyXL.activesheet.Range("A1")
MyXL.activesheet.Range("A1:I1").Font.Bold = True

xlRng.Range("A1") = "Name"
xlRng.Range("B1") = "Start"
xlRng.Range("C1") = "Finish"
xlRng.Range("D1") = "S1 Start"
xlRng.Range("E1") = "S1 Finish"
xlRng.Range("F1") = "S2 Start"
xlRng.Range("G1") = "S2 Finish"
xlRng.Range("H1") = "S3 Start"
xlRng.Range("I1") = "S3 Finish"

i = 2
If ActiveProject.Calendar.Exceptions.Count > 0 Then
    For Each E In ActiveProject.Calendar.Exceptions
        xlRng.Range("A" & i) = E.Name
        xlRng.Range("B" & i) = E.Start
        xlRng.Range("C" & i) = E.Finish
        xlRng.Range("D" & i) = E.Shift1.Start
        xlRng.Range("E" & i) = E.Shift1.Finish
        xlRng.Range("F" & i) = E.Shift2.Start
        xlRng.Range("G" & i) = E.Shift2.Finish
        xlRng.Range("H" & i) = E.Shift3.Start
        xlRng.Range("I" & i) = E.Shift3.Finish
        i = i + 1
    Next
End If

' II. WEEKDAYS
MyXL.ActiveWorkbook.Worksheets.Add.Name = "Weekdays"
MyXL.ActiveWorkbook.Worksheets("Weekdays").Activate
Set xlRng = MyXL.activesheet.Range("A1")
MyXL.activesheet.Range("A1:H1").Font.Bold = True

xlRng.Range("A1") = "Resource"
xlRng.Range("B1") = "Weekdays"
xlRng.Range("C1") = "S1 Start"
xlRng.Range("D1") = "S1 Finish"
xlRng.Range("E1") = "S2 Start"
xlRng.Range("F1") = "S2 Finish"
xlRng.Range("G1") = "S3 Start"
xlRng.Range("H1") = "S3 Finish"

i = 2
For Each R In ActiveProject.Resources
    If Not R Is Nothing Then
        For d = pjSunday To pjSaturday
            xlRng.Range("A" & i) = R.Name
            xlRng.Range("B" & i) = WeekdayName(d)
            xlRng.Range("C" & i) = R.Calendar.WeekDays(d).Shift1.Start
            xlRng.Range("D" & i) = R.Calendar.WeekDays(d).Shift1.Finish
            xlRng.Range("E" & i) = R.Calendar.WeekDays(d).Shift2.Start
            xlRng.Range("F" & i) = R.Calendar.WeekDays(d).Shift2.Finish
            xlRng.Range("G" & i) = R.Calendar.WeekDays(d).Shift3.Start
            xlRng.Range("H" & i) = R.Calendar.WeekDays(d).Shift3.Finish
            i = i + 1
        Next d
    End If
Next R

End Sub

Upvotes: 1

Views: 1172

Answers (1)

Rachel Hettinger
Rachel Hettinger

Reputation: 8442

Use the WeekDays object to get the shifts for each calendar. Here's an example that loops through each weekday and outputs the first 3 shift start and finish times. (Note: update the Range references to fit your desired format!)

Dim d As PjWeekday
For d = pjSunday To pjSaturday
    xlRng.Range("tbd", rownum) = R.Calendar.WeekDays(d).Shift1.Start
    xlRng.Range("tbd", rownum) = R.Calendar.WeekDays(d).Shift1.Finish
    xlRng.Range("tbd", rownum) = R.Calendar.WeekDays(d).Shift2.Start
    xlRng.Range("tbd", rownum) = R.Calendar.WeekDays(d).Shift2.Finish
    xlRng.Range("tbd", rownum) = R.Calendar.WeekDays(d).Shift3.Start
    xlRng.Range("tbd", rownum) = R.Calendar.WeekDays(d).Shift3.Finish
Next d

Upvotes: 1

Related Questions