Specific VBA code for exporting data to Excel

Hi, maybe I can help you with a small Macro:

you must create an Excel-sheet with following sheets:Activity, WBS-Dictionary, Resource, Filters, Calendar, Activity-Code and CDI.

Then create a Macro Extras->Macro->Visual Basic Editor and copy Macro-Text into this window.


This Macro will transform files from MS-Project to Excel.
It is based on VBA-language of MS-Excel and MS-Project. Therefore it is neccesary that the references are all loaded.

The ActiveX-Element of Microsoft Project must be activated : Extras -> Macros -> Visual Basic Editor. Ater that in the menu of the Visual Basic Editor: Extras -> References -> "Microsoft Project 10.0 Object Library"


Have fun and just ask questions


Option Explicit

Dim MSProj, ProjAppl As Object
Dim A As Assignment

Dim strName, TaskName, TaskSuccessor, Title, Test, Zwischen, Text1, Text2, Text3, Text4, Text5, Number1, Number2, Date1, Date2 As String
Dim n As Long
Dim bRet, Down, DoOff, FrOff, SaOff, SoOff As Boolean
Dim iColumn, iEmpty, DayWk, StartYear, FinishYear As Integer
Dim Cal As Calendar
Dim Fil As Filter
Dim CalRange, ResRange As Range
Dim aProj As Project

Dim MsgBoxRet As VbMsgBoxResult

’Primavera P3
Dim Pos1, Pos2, Pos3, Pos4, FieldValue As Long
’Dim ActRecord As Variant
Dim UserName, Password, ProjectName, SuccHelp, WBSstring, fname, ResString As String
Dim iRow, i, j, k, l, temp, WBS(1 To 7), LastLevel, CutOff, PredRow, findRow, ConstraintType, MoreHol As Integer
Dim Session, P3Proj, Act, Log, WBSVal, Succ, Res, CostAcc, P3Cal, P3GloCal, ResCal, ProjAbstr, ResAssign As Object
Dim HoDay, Level, ResPrice, ResLimit, ACodes, CodeVal, CDI, P3Filter, First, Last As Object

Private Sub ReadMSPjroject(Action As Integer)

’*** Open MS-Project File ***

Set MSProj = CreateObject("MSProject.Project")
Set ProjAppl = MSProj.Application

Title = "Please Select Microsoft Project File"
fname = Application.GetOpenFilename("Microsoft Project Files (*.mpp), *.mpp", , Title)

ProjAppl.FileOpen fname, ReadOnly:=False, FormatID:="MSProject.MPP"
Set aProj = ProjAppl.ActiveProject
strName = aProj.Name
Application.DisplayStatusBar = True
OptionsEdit DayLabelDisplay:=1

’**************************** RESOURCES *********************************

Application.DisplayStatusBar = True
Application.StatusBar = "Reading Resources..."
Worksheets("Resource").Activate
Cells.Select
Selection.ClearContents

Range(Cells(2, 1), Cells(2, 14)) = Array("Nr:", "Name", "MaterialLabel", "MaxUnits", "Type", "Initials", "Rate", "OvertimeRate", "Calendar", "Assignments", "Availabilities", "AvailableFrom", "AvailableTo", "Group")
Cells(2, 11) = "Number of"
Cells(2, 12) = "Limits"

iRow = 3
For i = 1 To aProj.Resources.Count
Cells(iRow, 1) = i
Cells(iRow, 2) = aProj.Resources(i).Name
Cells(iRow, 3) = aProj.Resources(i).MaterialLabel
Cells(iRow, 4) = aProj.Resources(i).MaxUnits
Cells(iRow, 5) = aProj.Resources(i).Type
Cells(iRow, 6) = aProj.Resources(i).Initials
Cells(iRow, 7) = aProj.Resources(i).StandardRate
If Cells(iRow, 7) <> "" Then
l = Len(Cells(iRow, 7).Text)
’Pos1 = InStr(1, Cells(iRow, 7).Text, "Std")
Pos2 = InStr(1, Cells(iRow, 7).Text, ",")
Cells(iRow, 7) = Left(Cells(iRow, 7), Pos2 + 2) * 8 ’IIf(Pos1 > 0, 8, 1)
End If

Cells(iRow, 8) = aProj.Resources(i).OvertimeRate
If Cells(iRow, 8) <> "" Then
l = Len(Cells(iRow, 8).Text)
’Pos1 = InStr(1, Cells(iRow, 8).Text, "Std")
Pos2 = InStr(1, Cells(iRow, 8).Text, ",")
Cells(iRow, 8) = Left(Cells(iRow, 8), Pos2 + 2) * 8 ’IIf(Pos1 > 0, 8, 1)
End If
Cells(iRow, 9) = aProj.Resources(i).BaseCalendar

Cells(iRow, 12) = aProj.Resources(i).AvailableFrom
Cells(iRow, 13) = aProj.Resources(i).AvailableTo
Cells(iRow, 14) = aProj.Resources(i).Group

iRow = iRow + 1
Next i

’*************************** FILTERS ***************************

Application.StatusBar = "Reading Filters..."
Worksheets("Filters").Activate
Cells.Select
Selection.ClearContents
Cells(1, 2) = "CurrentFilter:"
Cells(1, 3) = aProj.CurrentFilter

Range(Cells(2, 2), Cells(2, 9)) = Array("Nr", "Name", "FilterType", "Application", "Index", "Parent", "ShowInMenu", "ShowRelatedSummaryRows")

iRow = 3
For i = 1 To aProj.TaskFilters.Count
Cells(iRow, 2) = IIf(i > 1, i + 1, i)
Cells(iRow, 3) = aProj.TaskFilters(i).Name
If Cells(iRow, 3) = Cells(1, 3) Then Cells(1, 4) = Cells(iRow, 2)
temp = aProj.TaskFilters(i).FilterType
Select Case temp
Case 0
Cells(iRow, 4) = "TaskItem"
Case 1
Cells(iRow, 4) = "ResItem"
Case 2
Cells(iRow, 4) = "Other"
End Select
Cells(iRow, 5) = aProj.TaskFilters(i).Application
Cells(iRow, 6) = aProj.TaskFilters(i).Index
Cells(iRow, 7) = aProj.TaskFilters(i).Parent
Cells(iRow, 8) = aProj.TaskFilters(i).ShowInMenu
Cells(iRow, 9) = aProj.TaskFilters(i).ShowRelatedSummaryRows
iRow = iRow + 1
Next i

’************************** CALENDARS ************************************

Application.StatusBar = "Reading Calendars..."
Worksheets("Calendar").Activate
Cells.Select
Selection.ClearContents
Range(Cells(2, 1), Cells(2, 13)) = Array("Name", "MS-CalId", "P3-CalId", "So", "Mo", "Di", "Mi", "Do", "Fr", "Sa", "Days/Wk", "Number of", "Holidays")
Range(Cells(3, 1), Cells(3, 12)) = Array("Global", 0, 0, True, True, True, True, True, True, True, 7, 0)
iEmpty = 0
For i = 1 To aProj.BaseCalendars.Count
Application.StatusBar = "Reading Calendar " & i
If aProj.BaseCalendars(i).Name = (aProj.Calendar) Then
iRow = 4
iEmpty = iEmpty + 1
Else
iRow = i + 4 - iEmpty
End If
Cells(iRow, 1) = aProj.BaseCalendars(i).Name
Cells(iRow, 2) = aProj.BaseCalendars(i).Index
Cells(iRow, 3) = iRow - 3
Cells(iRow, 4) = aProj.BaseCalendars(i).WeekDays(1).Working ’So
Cells(iRow, 5) = aProj.BaseCalendars(i).WeekDays(2).Working ’Mo
Cells(iRow, 6) = aProj.BaseCalendars(i).WeekDays(3).Working
Cells(iRow, 7) = aProj.BaseCalendars(i).WeekDays(4).Working
Cells(iRow, 8) = aProj.BaseCalendars(i).WeekDays(5).Working
Cells(iRow, 9) = aProj.BaseCalendars(i).WeekDays(6).Working ’Fr
Cells(iRow, 10) = aProj.BaseCalendars(i).WeekDays(7).Working ’Sa

l = 0

For j = 1 To (aProj.BaseCalendars(i).Period(aProj.ProjectStart, aProj.ProjectFinish))
SoOff = (Weekday(CDate(aProj.ProjectStart) + j) = 1 And Cells(iRow, 4) = False)
DoOff = (Weekday(CDate(aProj.ProjectStart) + j) = 5 And Cells(iRow, 8) = False)
FrOff = (Weekday(CDate(aProj.ProjectStart) + j) = 6 And Cells(iRow, 9) = False)
SaOff = (Weekday(CDate(aProj.ProjectStart) + j) = 7 And Cells(iRow, 10) = False)
If Not SoOff And Not SaOff Then ’And Not FrOff
If aProj.BaseCalendars(i).Period(CDate(aProj.ProjectStart) + j).Working = False Then
Cells(iRow, 13 + l) = (CDate(aProj.ProjectStart) + j)
l = l + 1
End If
End If
Next j
Cells(iRow, 11) = 7 - IIf(Cells(iRow, 4), 0, 1) - IIf(Cells(iRow, 5), 0, 1) + IIf(Cells(iRow, 6), 0, 1) - IIf(Cells(iRow, 7), 0, 1) - IIf(Cells(iRow, 8), 0, 1) - IIf(Cells(iRow, 9), 0, 1) - IIf(Cells(iRow, 10), 0, 1)
Cells(iRow, 12) = l

Next i

’************************** WBS-DICTIONARY ************************************

Worksheets("WBS-Dictionary").Activate
Cells.Select
Selection.ClearContents
Cells(2, 1) = "Level"
Cells(2, 2) = "Value"
Cells(2, 3) = "Description"

’************************** CUSTOM DATA ITEMS ************************************

Application.StatusBar = "Reading Custom Data Items..."
Worksheets("CDI").Activate
Cells.Select
Selection.ClearContents
Range(Cells(2, 2), Cells(2, 5)) = Array("Description", "Length", "Name", "Type")

iRow = 3
On Error Resume Next
If (CustomFieldGetName(pjCustomTaskNumber1)) <> "" Then
Cells(iRow, 1) = "Number1"
Cells(iRow, 2) = (CustomFieldGetName(pjCustomTaskNumber1))
Number1 = (CustomFieldGetName(pjCustomTaskNumber1))
’Cells(iRow, 3) = 1
Cells(iRow, 4) = "Nr1"
Cells(iRow, 5) = "N"
’ For i = 1 To 100
’ Cells(iRow, 4 + i * 2) = CustomFieldValueListGetItem(pjCustomTaskNumber1, pjValueListValue, i)
’ If Cells(iRow, 4 + i * 2) = "" Then Exit For
’ Cells(iRow, 3) = IIf(Len(CustomFieldValueListGetItem(pjCustomTaskNumber1, pjValueListValue, i)) > Cells(iRow, 3), Len((CustomFieldValueListGetItem(pjCustomTaskNumber1, pjValueListValue, i))), Cells(iRow, 3))
’ Cells(iRow, 5 + i * 2) = CustomFieldValueListGetItem(pjCustomTaskNumber1, pjValueListDescription, i)
’ Cells(iRow, 5) = i
’ Next i
iRow = iRow + 1
End If

If (CustomFieldGetName(pjCustomTaskNumber2)) <> "" Then
Cells(iRow, 1) = "Number2"
Cells(iRow, 2) = (CustomFieldGetName(pjCustomTaskNumber2))
Number2 = (CustomFieldGetName(pjCustomTaskNumber2))
’Cells(iRow, 3) = 1
Cells(iRow, 4) = "Nr2"
Cells(iRow, 5) = "N"
’For i = 1 To 100
’ Cells(iRow, 4 + i * 2) = CustomFieldValueListGetItem(pjCustomTaskNumber1, pjValueListValue, i)
’ If Cells(iRow, 4 + i * 2) = "" Then Exit For
’ Cells(iRow, 3) = IIf(Len(CustomFieldValueListGetItem(pjCustomTaskNumber1, pjValueListValue, i)) > Cells(iRow, 3), Len((CustomFieldValueListGetItem(pjCustomTaskNumber1, pjValueListValue, i))), Cells(iRow, 3))
’ Cells(iRow, 5 + i * 2) = CustomFieldValueListGetItem(pjCustomTaskNumber1, pjValueListDescription, i)
’ Cells(iRow, 5) = i
’Next i
iRow = iRow + 1
End If

If (CustomFieldGetName(pjCustomTaskDate1)) <> "" Then
Cells(iRow, 1) = "Date1"
Cells(iRow, 2) = (CustomFieldGetName(pjCustomTaskDate1))
Date1 = (CustomFieldGetName(pjCustomTaskDate1))
’Cells(iRow, 3) = 1
Cells(iRow, 4) = "Dat1"
Cells(iRow, 5) = "S"
’ For i = 1 To 100
’ Cells(iRow, 4 + i * 2) = CustomFieldValueListGetItem(pjCustomTaskNumber1, pjValueListValue, i)
’ If Cells(iRow, 4 + i * 2) = "" Then Exit For
’ Cells(iRow, 3) = IIf(Len(CustomFieldValueListGetItem(pjCustomTaskNumber1, pjValueListValue, i)) > Cells(iRow, 3), Len((CustomFieldValueListGetItem(pjCustomTaskNumber1, pjValueListValue, i))), Cells(iRow, 3))
’ Cells(iRow, 5 + i * 2) = CustomFieldValueListGetItem(pjCustomTaskNumber1, pjValueListDescription, i)
’ Cells(iRow, 5) = i
’ Next i
iRow = iRow + 1
End If

If (CustomFieldGetName(pjCustomTaskDate2)) <> "" Then
Cells(iRow, 1) = "Dat2"
Cells(iRow, 2) = (CustomFieldGetName(pjCustomTaskDate2))
Date2 = (CustomFieldGetName(pjCustomTaskDate2))
’Cells(iRow, 3) = 1
Cells(iRow, 4) = "Date2"
Cells(iRow, 5) = "S"
’ For i = 1 To 100
’ Cells(iRow, 4 + i * 2) = CustomFieldValueListGetItem(pjCustomTaskNumber1, pjValueListValue, i)
’ If Cells(iRow, 4 + i * 2) = "" Then Exit For
’ Cells(iRow, 3) = IIf(Len(CustomFieldValueListGetItem(pjCustomTaskNumber1, pjValueListValue, i)) > Cells(iRow, 3), Len((CustomFieldValueListGetItem(pjCustomTaskNumber1, pjValueListValue, i))), Cells(iRow, 3))
’ Cells(iRow, 5 + i * 2) = CustomFieldValueListGetItem(pjCustomTaskNumber1, pjValueListDescription, i)
’ Cells(iRow, 5) = i
’ Next i
End If

’****************************** ACTIVITY-CODE *************************************

Worksheets("Activity-Code").Activate
Cells.Select
Selection.ClearContents
Range(Cells(2, 2), Cells(2, 6)) = Array("Description", "Length", "Name", "Number of", "Values")

iRow = 3
If (CustomFieldGetName(pjCustomTaskText1)) <> "" Then
Cells(iRow, 1) = "Text1"
Cells(iRow, 2) = (CustomFieldGetName(pjCustomTaskText1))
Text1 = (CustomFieldGetName(pjCustomTaskText1))
Cells(iRow, 3) = 1
Cells(iRow, 4) = "TXT1"
For i = 1 To 1000
Cells(iRow, 4 + i * 2) = CustomFieldValueListGetItem(pjCustomTaskText1, pjValueListValue, i)
If Cells(iRow, 4 + i * 2) = "" Then Exit For
Cells(iRow, 3) = IIf(Len(CustomFieldValueListGetItem(pjCustomTaskText1, pjValueListValue, i)) > Cells(iRow, 3), Len((CustomFieldValueListGetItem(pjCustomTaskText1, pjValueListValue, i))), Cells(iRow, 3))
Cells(iRow, 5 + i * 2) = CustomFieldValueListGetItem(pjCustomTaskText1, pjValueListDescription, i)
Cells(iRow, 5) = i
Next i
iRow = iRow + 1
End If

If (CustomFieldGetName(pjCustomTaskText2)) <> "" Then
Cells(iRow, 1) = "Text2"
Cells(iRow, 2) = (CustomFieldGetName(pjCustomTaskText2))
Text2 = (CustomFieldGetName(pjCustomTaskText2))
Cells(iRow, 3) = 1
Cells(iRow, 4) = "TXT2"

For i = 1 To 1000
Cells(iRow, 4 + i * 2) = CustomFieldValueListGetItem(pjCustomTaskText2, pjValueListValue, i)
If Cells(iRow, 4 + i * 2) = "" Then Exit For
Cells(iRow, 3) = IIf(Len(CustomFieldValueListGetItem(pjCustomTaskText2, pjValueListValue, i)) > Cells(iRow, 3), Len((CustomFieldValueListGetItem(pjCustomTaskText2, pjValueListValue, i))), Cells(iRow, 3))
Cells(iRow, 5 + i * 2) = CustomFieldValueListGetItem(pjCustomTaskText2, pjValueListDescription, i)
Cells(iRow, 5) = i
Next i
iRow = iRow + 1
End If

If (CustomFieldGetName(pjCustomTaskText3)) <> "" Then
Cells(iRow, 1) = "Text3"
Cells(iRow, 2) = (CustomFieldGetName(pjCustomTaskText3))
Text3 = (CustomFieldGetName(pjCustomTaskText3))
Cells(iRow, 3) = 1
Cells(iRow, 4) = "TXT3"
Cells(iRow, 5) = 0
For i = 1 To 1000
Cells(iRow, 4 + i * 2) = CustomFieldValueListGetItem(pjCustomTaskText3, pjValueListValue, i)
If Cells(iRow, 4 + i * 2) = "" Then Exit For
Cells(iRow, 3) = IIf(Len(CustomFieldValueListGetItem(pjCustomTaskText3, pjValueListValue, i)) > Cells(iRow, 3), Len((CustomFieldValueListGetItem(pjCustomTaskText3, pjValueListValue, i))), Cells(iRow, 3))
Cells(iRow, 5 + i * 2) = CustomFieldValueListGetItem(pjCustomTaskText3, pjValueListDescription, i)
Cells(iRow, 5) = i
Next i
iRow = iRow + 1
End If

If (CustomFieldGetName(pjCustomTaskText4)) <> "" Then
Cells(iRow, 1) = "Text4"
Cells(iRow, 2) = (CustomFieldGetName(pjCustomTaskText4))
Text4 = (CustomFieldGetName(pjCustomTaskText4))
Cells(iRow, 3) = 1
Cells(iRow, 4) = "TXT4"
Cells(iRow, 5) = 0
For i = 1 To 1000
Cells(iRow, 4 + i * 2) = CustomFieldValueListGetItem(pjCustomTaskText4, pjValueListValue, i)
If Cells(iRow, 4 + i * 2) = "" Then Exit For
Cells(iRow, 3) = IIf(Len(CustomFieldValueListGetItem(pjCustomTaskText4, pjValueListValue, i)) > Cells(iRow, 3), Len((CustomFieldValueListGetItem(pjCustomTaskText4, pjValueListValue, i))), Cells(iRow, 3))
Cells(iRow, 5 + i * 2) = CustomFieldValueListGetItem(pjCustomTaskText4, pjValueListDescription, i)
Cells(iRow, 5) = i
Next i
iRow = iRow + 1
End If

If (CustomFieldGetName(pjCustomTaskText5)) <> "" Then
Cells(iRow, 1) = "Text5"
Cells(iRow, 2) = (CustomFieldGetName(pjCustomTaskText5))
Text5 = (CustomFieldGetName(pjCustomTaskText5))
Cells(iRow, 3) = 1
Cells(iRow, 4) = "TXT5"
Cells(iRow, 5) = 0
For i = 1 To 1000
Cells(iRow, 4 + i * 2) = CustomFieldValueListGetItem(pjCustomTaskText5, pjValueListValue, i)
If Cells(iRow, 4 + i * 2) = "" Then Exit For
Cells(iRow, 3) = IIf(Len(CustomFieldValueListGetItem(pjCustomTaskText5, pjValueListValue, i)) > Cells(iRow, 3), Len((CustomFieldValueListGetItem(pjCustomTaskText5, pjValueListValue, i))), Cells(iRow, 3))
Cells(iRow, 5 + i * 2) = CustomFieldValueListGetItem(pjCustomTaskText5, pjValueListDescription, i)
Cells(iRow, 5) = i
Next i
End If

’****************************** ACTIVITIES ***************************************

Worksheets("Activity").Activate
Cells.Select
Selection.ClearContents

Cells(1, 1) = "Activity"
Cells(1, 5) = "Links"
Cells(1, 8) = "Headers"
Cells(1, 13) = "Constraints"
Cells(1, 15) = "Early Dates"
Cells(1, 17) = "Actual Dates"
Cells(1, 19) = "ProjStart:"
Cells(1, 20) = aProj.ProjectStart
Cells(1, 21) = "ProjFinish:"
Cells(1, 22) = aProj.ProjectFinish
Cells(1, 23) = "StatusDate:"
Cells(1, 24) = aProj.StatusDate
Cells(1, 25) = "Version:"
Cells(1, 26) = aProj.VersionName
Cells(1, 27) = "Digits:"
Cells(1, 28) = aProj.CurrencyDigits
Cells(1, 29) = "StartWeekOn:"
Cells(1, 30) = aProj.StartWeekOn
Cells(1, 31) = "Revision."
Cells(1, 32) = aProj.RevisionNumber
Cells(1, 33) = "Print Date:"
Cells(1, 34) = aProj.LastPrintedDate

Range(Cells(2, 1), Cells(2, 8)) = Array("ID", "UniqueID", "Name", "OD", "Number of", "Successors", "Milestone", "Summary")
Range(Cells(2, 9), Cells(2, 15)) = Array("Number", "Level", "WBS", "Note", "Date", "Type", "Early Start")
Range(Cells(2, 16), Cells(2, 20)) = Array("Early Finish", "Actual Start", "Actual Finish", "Perc. Compl.", "Calendar")
Range(Cells(2, 21), Cells(2, 29)) = Array(Text1, Text2, Text3, Text4, Text5, Number1, Number2, Date1, Date2)
Cells(2, 30) = "Resources"

j = 1
WBS(1) = WBS(2) = WBS(3) = WBS(4) = WBS(5) = WBS(6) = WBS(7) = 1
temp = 1
iEmpty = 0
LastLevel = 0

For i = 1 To aProj.Tasks.Count
Application.StatusBar = "Reading activity " & i & " of " & aProj.Tasks.Count
If Not aProj.Tasks(i) Is Nothing Then

iRow = i + 2 - iEmpty

Cells(iRow, 1) = aProj.Tasks(i).ID
’Cells(iRow, 2) = aProj.Tasks(i).UniqueID
Cells(iRow, 3) = aProj.Tasks(i).Name
Cells(iRow, 4) = aProj.Tasks(i).Duration / (aProj.HoursPerDay * 60)
Cells(iRow, 5) = aProj.Tasks(i).SuccessorTasks.Count
Cells(iRow, 6) = aProj.Tasks(i).Successors
Cells(iRow, 7) = aProj.Tasks(i).Milestone
Cells(iRow, 8) = aProj.Tasks(i).Summary

’**************************** Activity.WBS-Assignment *****************************

WBSstring = ""

If aProj.Tasks(i).OutlineLevel = LastLevel Then
WBS(aProj.Tasks(i).OutlineLevel) = WBS(aProj.Tasks(i).OutlineLevel) + 1
Else
If aProj.Tasks(i).OutlineLevel > LastLevel Then
WBS(aProj.Tasks(i).OutlineLevel) = 1
Down = False
ElseIf aProj.Tasks(i).OutlineLevel < LastLevel Then
WBS(aProj.Tasks(i).OutlineLevel) = WBS(aProj.Tasks(i).OutlineLevel) + 1
Down = True
End If
End If


For l = 1 To aProj.Tasks(i).OutlineLevel
WBSstring = WBSstring & IIf(WBS(l) < 10, "0" & WBS(l), WBS(l))
Next l

If aProj.Tasks(i).Summary = True Or aProj.Tasks(i).OutlineLevel = 1 Or (aProj.Tasks(i).OutlineLevel < LastLevel And WBS(aProj.Tasks(i).OutlineLevel) > 1) Or (aProj.Tasks(i).OutlineLevel = LastLevel And Down = True) Then
Worksheets("WBS-Dictionary").Cells(j + 2, 1) = aProj.Tasks(i).OutlineLevel
Worksheets("WBS-Dictionary").Cells(j + 2, 2) = WBSstring
Worksheets("WBS-Dictionary").Cells(j + 2, 3) = aProj.Tasks(i).Name
j = j + 1
Else
WBSstring = Left(WBSstring, Len(WBSstring) - 2)
End If
LastLevel = aProj.Tasks(i).OutlineLevel
If aProj.Tasks(i).OutlineLevel > Worksheets("WBS-Dictionary").Cells(1, 1) Then
Worksheets("WBS-Dictionary").Cells(1, 1) = aProj.Tasks(i).OutlineLevel
End If
Worksheets("Activity").Activate
Cells(iRow, 9) = aProj.Tasks(i).OutlineNumber
Cells(iRow, 10) = aProj.Tasks(i).OutlineLevel
Cells(iRow, 11) = WBSstring

’**************************************************************************************

Cells(iRow, 12) = aProj.Tasks(i).Notes
Cells(iRow, 13) = aProj.Tasks(i).ConstraintDate
Cells(iRow, 14) = aProj.Tasks(i).ConstraintType
Cells(iRow, 15) = aProj.Tasks(i).EarlyStart
Cells(iRow, 16) = aProj.Tasks(i).EarlyFinish
Cells(iRow, 17) = aProj.Tasks(i).ActualStart
Cells(iRow, 18) = aProj.Tasks(i).ActualFinish
Cells(iRow, 19) = aProj.Tasks(i).PercentComplete
Cells(iRow, 20) = aProj.Tasks(i).Calendar
Cells(iRow, 21) = aProj.Tasks(i).Text1
Cells(iRow, 22) = aProj.Tasks(i).Text2
Cells(iRow, 23) = aProj.Tasks(i).Text3
Cells(iRow, 24) = aProj.Tasks(i).Text4
Cells(iRow, 25) = aProj.Tasks(i).Text5
Cells(iRow, 26) = aProj.Tasks(i).Number1
Cells(iRow, 27) = aProj.Tasks(i).Number2
Cells(iRow, 28) = aProj.Tasks(i).Date1
Cells(iRow, 29) = aProj.Tasks(i).Date2


’********************* ACTIVITY.RESOURCE ASSIGNMENTS ******************

Set ResRange = Worksheets("Resource").Range(Worksheets("Resource").Cells(3, 2), Worksheets("Resource").Cells(202, 13))
iColumn = 31
For Each A In aProj.Tasks(i).Assignments
Cells(iRow, iColumn) = A.ResourceName

’Cells(iRow, iColumn) = Application.WorksheetFunction.VLookup(Cells(iRow, iColumn), Worksheets("Resource").Range("ResRange"), 5)


If A.ResourceType = 0 Then
Cells(iRow, iColumn + 1) = A.Units * Cells(iRow, 4)
Else
Cells(iRow, iColumn + 1) = A.Units
End If
iColumn = iColumn + 4 ’35,39,43
Next A
Cells(iRow, 30) = (iColumn - 31) / 4
Else
iEmpty = iEmpty + 1
End If
Next i
Exit Function

NoFileOpen:
’MsgBox MSG_NOFILEOPEN, vbExclamation + R_TO_L, Title:=Application.Name
End ’Makro beenden.

End Sub

Hannes

Thankyou very much for your "small" macro. I will give it a go and will probably have to get back to you as I know absolutely nothing about macros.

Many regards

Andrew

Hi Andrew,

I just did, what you have done. Due to extracting this macro from a large program an error occured -> the first line after the declaration part should read:


Private Sub ReadMSPjroject()

instead of

Private Sub ReadMSPjroject(Action As Integer)




I prepared the extracted macro in an separate Excel-file now and tested it - just send yr e-mail address, I will send you the file.

Requests from other persons welcome as well.

any chance of a how to, Ive not tried to write a macro so have tried and failed - even with the fix.

Hi,

as allready said, send me a mail and I will send you the file with the macro .or. write down the error message / problem, and I will try to give you the answer. You can send the mail to:
Hannes.de-Bruyne@hochtief.de

Hannes