VBA
18.04.2008 09:00:43
Juan
mit folgendem Code gelingt es mir einige Daten aus dem MS Project abzufragen.
Ich würde gerne den Code vervollständigen, so dass wenn die MS Project Datei vor dem Abrufen schon offen ist, die später nicht geschlossen wird. Die MSP Datei sollte nur geschlossen werden, wenn die vorher nicht offen gewesen ist.
Ich habe es versucht aber leider nicht hingekriegt.
Geht das?
Ich bedanke mich im Voraus und freue mich auf jeden Hinweis.
Beste Grüße,
Juan.
Private Sub CmdImportAP_Click()
Dim Datei
Dim mpApp As MSProject.Application
Dim Proj As Project
Dim T As Task
Dim xlcell As Range
Dim Zelle As Range
Dim Spalte As Long
Dim X As String
Dim Y As String
Dim Gesucht As Variant
Dim objSheet As Worksheet
Datei = Application.GetOpenFilename("Microsoft Project Datei (*.mpp), *.mpp")
If Datei = False Then
MsgBox "Keine Datei wurde ausgewählt."
Exit Sub
End If
Worksheets(4).Visible = True
Worksheets(4).Select
Application.ScreenUpdating = False
For Each Zelle In Worksheets(4).Range("A60:A560").Rows
If Zelle.Hidden = True Then
Zelle.Hidden = False
End If
Next
Application.ScreenUpdating = True
Set mpApp = New MSProject.Application
mpApp.Visible = False
mpApp.FileOpen Datei
Set objSheet = Worksheets(4)
With objSheet
Gesucht = Range("RangeDatum").Value
Set xlcell = .Range("RangeLaufzeit").Find(what:=Gesucht, _
LookAt:=xlWhole, LookIn:=xlValues, MatchCase:=True)
If Not xlcell Is Nothing Then
Spalte = xlcell.Column
Else
MsgBox "Es wurde kein passendes Datum gefunden.", vbInformation
Exit Sub
End If
Set xlcell = .Cells(62, Spalte) 'Set xlCell = xlCell.Offset(1, 0)
For Each T In mpApp.ActiveProject.Tasks
If Not T Is Nothing Then
If Not T.Summary Then
xlcell.Value = T.PercentComplete
xlcell.NumberFormat = "General\%"
Set xlcell = xlcell.Offset(1, 0)
End If
End If
Next T
Set xlcell = xlcell.Offset(-1, 0)
Y = xlcell.Address
X = Cells(61, Spalte).Address
.Range(X & ":" & Y).Select
End With
mpApp.FileClose pjDoNotSave
mpApp.Quit
Set objSheet = Nothing
Set xlcell = Nothing
Set mpApp = Nothing
AppActivate "Microsoft Excel"
Application.ActiveWorkbook.Worksheets(3).Activate
Range("CB20").Select
'Sheets(3).Range("CB20").Select
End Sub