Guild of Project Controls: Compendium | Roles | Assessment | Certifications | Membership

Tips on using this forum..

(1) Explain your problem, don't simply post "This isn't working". What were you doing when you faced the problem? What have you tried to resolve - did you look for a solution using "Search" ? Has it happened just once or several times?

(2) It's also good to get feedback when a solution is found, return to the original post to explain how it was resolved so that more people can also use the results.

Specific VBA code for exporting data to Excel

5 replies [Last post]
Wed, 2006-10-11 09:26
Andrew Owenson
User offline. Last seen 16 years 17 weeks ago. Offline
Joined: 10 Nov 2005
Posts: 48
Groups: None
Guys

I have a procurement programme in MSP which I have linked to an excel file. I have a planned, actual an forecast date for each activity, and about 15 activities per package. I have a reference programme with 115 packages. I then copy and rename to suit a new project. The problem I have is that the excel file is extremely slow and the connections seem fragile to say the least. Is there anyone out there who can give me a specific code to export the baseline, actual and current date to a specific cell in excel. I know absolutely nothing about Visual basic, and I am following up a previous thread in which I was given various places to look up, but did not give me the answer I am looking for. It does not have to necessarily export to excel, but produce a report which gives the package on the left with the planned actual and forecast dates for each activity in a spreadsheet fashion.

Thankyou in advance - a frustrated planner
Top

Replies

Wed, 2006-10-18 02:52
#1
Hannes de Bruyne
User offline. Last seen 1 year 50 weeks ago. Offline
Joined: 25 Jul 2005
Posts: 154
Groups: None
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
Top
Tue, 2006-10-17 12:36
#2
John Smitt
User offline. Last seen 17 years 45 weeks ago. Offline
Joined: 30 Jan 2005
Posts: 38
Groups: Petro-Chem / Oil & Gas
any chance of a how to, Ive not tried to write a macro so have tried and failed - even with the fix.
Top
Tue, 2006-10-17 03:42
#3
Hannes de Bruyne
User offline. Last seen 1 year 50 weeks ago. Offline
Joined: 25 Jul 2005
Posts: 154
Groups: None
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.
Top
Mon, 2006-10-16 04:08
#4
Andrew Owenson
User offline. Last seen 16 years 17 weeks ago. Offline
Joined: 10 Nov 2005
Posts: 48
Groups: None
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
Top
Mon, 2006-10-16 02:55
#5
Hannes de Bruyne
User offline. Last seen 1 year 50 weeks ago. Offline
Joined: 25 Jul 2005
Posts: 154
Groups: None
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
Top