Specific VBA code for exporting data to Excel

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

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

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.

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