TimeScaleData, mir fehlt eine Schleife.
28.04.2008 15:31:00
Juan
weiter in der Absicht einige Daten aus MS Project zu importieren bin ich jetzt auf einen neuen Problem gestoßen.
Um die Projektkosten und den Aufwand intervallmäßig abzufragen benutze ich die Funktion
TimeScaleData (StartDate, EndDate, Type [Kosten, Arbeit,...], Unit [täglich, monatlich, quartalsweise,...], Count).
Bis dahin alles in Ordnung.
Und nun das Problem: es gibt keine halbmonatliche "Unit".
Man kann es wöchentlich machen, sogar 14-tägig wenn man "Count := 2" stellt.
Aber nicht halbmonatlich (1. bis 15., 16. bis Ende des Monates).
Der einzige Weg der dies vielleicht noch ermöglichen würde, wäre die Daten durch eine Schleife zu iterieren, indem die tägliche Werte irgendwie nach diesen Intervallen/Muster (1.-15., 16.-Ende, 1.-15, ...) addiert werden. Leider fällt mir diesbezüglich nichts ein.
Die intervallmässige Werte sollten in eine Tabelle geschrieben werden, die ab der 4. Spalte anfängt.
Hat jemand eine Idee?
Ich lege den Code bei und hoffe dass jemand mir damit helfen kann.
Beste Grüße,
Juan.
Private Sub CmdImportRes_Click()
Dim Datei As String
Dim pfad
Dim r As Integer
Dim mApp As MSProject.Application
Dim proj As MSProject.Project
Dim xlcell As Range
Dim found As Boolean
Dim sdatum As Date
Dim edatum As Date
Dim ResName As String
Dim c As Range, RR As Range
Dim x As Integer, AnzInt As Integer
Dim strValue As String
Dim tsv As Object
pfad = Application.GetOpenFilename("Microsoft Project Datei (*.mpp), *.mpp")
If pfad = False Then
MsgBox "Keine Datei wurde ausgewählt."
Exit Sub
Else
Datei = Mid$(pfad, InStrRev(pfad, "\") + 1)
Datei = Left(Datei, Len(Datei) - 4)
MsgBox Datei & vbCrLf & pfad, vbInformation
End If
Set mApp = New MSProject.Application
found = False
If mApp.Visible = True Then
MsgBox "visible", vbInformation
If mApp.Projects.Count > 0 Then
MsgBox "> 0", vbInformation
For Each proj In mApp.Projects
MsgBox proj.Name, vbInformation
If proj.Name = Datei Then
found = True
proj.Activate
MsgBox "activated", vbInformation
End If
Next
End If
End If
If found = True Then
MsgBox "works...", vbInformation
mApp.Visible = False
viewapply (mApp.ActiveProject.ViewList(3))
Set xlcell = Range("A2")
For r = 1 To mApp.ActiveProject.Resources.Count
If Not mApp.ActiveProject.Resources.Item(r) Is Nothing Then
If mApp.ActiveProject.Resources.Item(r).Type = 0 Then ' _
pjResourceTypeWork
xlcell.Value = mApp.ActiveProject.Resources.Item(r).Name
Set xlcell = xlcell.Offset(1, 0) 'step down 1 row
ElseIf mApp.ActiveProject.Resources.Item(r).Type = 1 Then
xlcell.Value = mApp.ActiveProject.Resources.Item(r).Name
Set xlcell = xlcell.Offset(1, 0)
End If
End If
Next
sdatum = ActiveSheet.Range("C24").Value
edatum = ActiveSheet.Range("C25").Value
AnzInt = DateDiff("d", sdatum, edatum) + 1
For Each c In ActiveSheet.Range("RangeRessourcen")
ResName = Cells(c.Row, 1).Value
If ResName "" Then
For r = 1 To mApp.ActiveProject.Resources.Count
If Not mApp.ActiveProject.Resources.Item(r) Is Nothing Then
If mApp.ActiveProject.Resources.Item(r).Name = ResName Then
Application.Caption = "Datensatz" & r
Application.Cells(c.Row, 2).Value = (mApp.ActiveProject. _
Resources(r).Cost)* 1 'gesamte Kosten
Application.Cells(c.Row, 3).Value = (mApp.ActiveProject. _
Resources(r).Work / 60)* 1 'gesamte Arbeit
For x = 1 To AnzInt
Set tsv = mApp.ActiveProject.Resources(r).TimeScaleData( _
sdatum, edatum, Type:=13, TimescaleUnit:=4) 'pjResourcesTimeScaledWork, täglich
'HIER SOLLTE DIE SCHLEIFE LIEGEN
'strValue = Val(tsv(x).Value) / 60
'Application.Cells(c.Row, x + 3).Value = strValue * 1
Next x
End If
End If
Next r
Set tsv = Nothing
End If
Next
Application.Cells(1, 1).Select
ElseIf found = False Then
Set mApp = New MSProject.Application
mApp.Visible = False
mApp.FileOpen pfad
viewapply (mApp.ActiveProject.ViewList(3))
Set xlcell = Range("A2")
For r = 1 To mApp.ActiveProject.Resources.Count
'-------- hier kommt das gleiche nochmal --------
Next
Application.Cells(1, 1).Select
mApp.FileClose pjDoNotSave
End If
Set mApp = Nothing
Set xlcell = Nothing
Set tsv = Nothing
Range("A1").Select
End Sub