-
Jul 6th, 2018, 08:09 AM
#1
Thread Starter
Junior Member
[RESOLVED] Loop to paste new file location in the next cell below previous.
Good Morning,
I'm attempting to create a VBA Code that allows you to upload multiple .mpp project files and they would load into a list with their file location in order to be pulled from later in code into Excel. I need to create a loop that makes sense and also one that will paste the new hyperlink to the cell under it.
Ultimately here are the steps
1. Loop to open multiple files and paste them into a spreadsheet and their hyperlinks into a cell and as the project files are selected it saves the hyperlink to the next cell below. Then, reads the hyperlinks and dumps all the hyperlinks, opens .mpp project files and then copies specific columns and pastes them into a worksheet. I'm using old sample code and have only really made changes to the "Sub ConnectSchedule()"
Code:
Option Explicit
Sub ConnectSchedule()
Dim File As String
Dim File2 As String
Dim File3 As String
Dim File4 As String
File = findFile("MS Project Schedule")
If File = "" Then
MsgBox "No Schedule Selected", vbOKOnly, "Please Select a File"
Else
With ThisWorkbook.Sheets("TestBurndown")
.Hyperlinks.Add .Range("B2"), File
With .Range("C2")
.NumberFormat = ";;;"
.FormulaR1C1 = File
End With
With .Range("B2").Font
.Size = 11
.Bold = True
End With
.Shapes("RefreshBtn").Visible = True
.Shapes("Reconnxbtn").Visible = True
End With
End If
File2 = findFile2("MS Project Schedule")
If File2 = "" Then
MsgBox "No Schedule Selected", vbOKOnly, "Please Select a File"
Else
With ThisWorkbook.Sheets("TestBurndown")
.Hyperlinks.Add .Range("B3"), File2
With .Range("C3")
.NumberFormat = ";;;"
.FormulaR1C1 = File2
End With
With .Range("B3").Font
.Size = 11
.Bold = True
End With
.Shapes("RefreshBtn").Visible = True
.Shapes("Reconnxbtn").Visible = True
End With
End If
File3 = findFile3("MS Project Schedule")
If File3 = "" Then
MsgBox "No Schedule Selected", vbOKOnly, "Please Select a File"
Else
With ThisWorkbook.Sheets("TestBurndown")
.Hyperlinks.Add .Range("B4"), File3
With .Range("C4")
.NumberFormat = ";;;"
.FormulaR1C1 = File3
End With
With .Range("B4").Font
.Size = 11
.Bold = True
End With
.Shapes("RefreshBtn").Visible = True
.Shapes("Reconnxbtn").Visible = True
End With
End If
File4 = findFile4("MS Project Schedule")
If File4 = "" Then
MsgBox "No Schedule Selected", vbOKOnly, "Please Select a File"
Else
With ThisWorkbook.Sheets("TestBurndown")
.Hyperlinks.Add .Range("B5"), File4
With .Range("C5")
.NumberFormat = ";;;"
.FormulaR1C1 = File4
End With
With .Range("B5").Font
.Size = 11
.Bold = True
End With
.Shapes("RefreshBtn").Visible = True
.Shapes("Reconnxbtn").Visible = True
End With
End If
End Sub
Function Update_Schedule() As Boolean
Dim apProject, prSched, nTask, nTimePhaseItem As Object, File As String
Dim rsOrg, colDept As Object, strDept(), strRes() As String, i As Integer, blSave As Boolean
File = ThisWorkbook.Sheets("TestBurndown").Range("B2").Value
Set apProject = CreateObject("MSProject.Application")
Set prSched = CreateObject("MSProject.Project")
Set colDept = CreateObject("Scripting.Dictionary")
On Error GoTo NoSched
apProject.FileOpenEx (File)
Set prSched = apProject.ActiveProject
With ThisWorkbook.Sheets("Schedule").ListObjects("Proj_Tasks")
i = 0
With .DataBodyRange
If .Rows.Count > 1 Then
.Offset(1, 0).Resize(.Rows.Count - 1, .Columns.Count).Rows.Delete
End If
End With
For Each nTask In prSched.Tasks
If Not nTask Is Nothing Then
If Not nTask.Summary Then
With .ListRows.Add(AlwaysInsert:=True)
.Range.Cells(1, 1).Value = nTask.ID
.Range.Cells(1, 2).Value = Trim$(nTask.Name)
If nTask.BaselineFinish = "NA" Then
nTask.BaselineFinish = nTask.Finish
blSave = True
End If
.Range.Cells(1, 3).Value = Format(nTask.BaselineFinish, "mm/dd/yyyy")
.Range.Cells(1, 4).Value = Format(nTask.Finish, "mm/dd/yyyy")
.Range.Cells(1, 5).Value = nTask.PercentComplete / 100
.Range.Cells(1, 6).Value = nTask.Text1 'Schedule Template lists as 'Phase'
.Range.Cells(1, 7).Value = nTask.Text2 'Schedule Template lists as 'Chart_Milestone'
End With
i = i + 1
End If
End If
Next nTask
If i > 0 Then .ListRows(1).Delete
End With
'pjdonotsave = 0, pjSave = 1, pjPromptSave = 2
If blSave Then apProject.FileCloseEx 1 Else apProject.FileCloseEx 0
Set prSched = Nothing
Update_Schedule = True
Exit Function
NoSched:
Err.Clear
MsgBox "Project schedule not found - " & Chr(13) & "Template will load data from the Schedule tab.", vbOKOnly, "Reconnect Schedule"
Update_Schedule = False
Set prSched = Nothing
End Function
Function findFile(fileName As String) As String
Dim indexFD As FileDialog
Dim srcIndex As Workbook
Dim ynCanx As Integer
RetrySub:
'File Dialog Setup and Return
Set indexFD = Application.FileDialog(msoFileDialogFilePicker)
'------------------------------------------------------------
indexFD.Title = "Select the " & fileName & " for use"
'Set Index file Filters
indexFD.Filters.Clear
indexFD.InitialFileName = ActiveWorkbook.Path
indexFD.Filters.Add "Project Schedules", "*.mpp"
indexFD.FilterIndex = 1
indexFD.ButtonName = "Choose &File"
If indexFD.Show <> -1 Then
Exit Function
Else
findFile = indexFD.SelectedItems(1)
End If
Set indexFD = Nothing
'------------------------------------------------------------
End Function
Function findFile2(fileName As String) As String
Dim indexFD As FileDialog
Dim srcIndex As Workbook
Dim ynCanx As Integer
RetrySub:
'File Dialog Setup and Return
Set indexFD = Application.FileDialog(msoFileDialogFilePicker)
'------------------------------------------------------------
indexFD.Title = "Select the " & fileName & " for use"
'Set Index file Filters
indexFD.Filters.Clear
indexFD.InitialFileName = ActiveWorkbook.Path
indexFD.Filters.Add "Project Schedules", "*.mpp"
indexFD.FilterIndex = 1
indexFD.ButtonName = "Choose &File"
If indexFD.Show <> -1 Then
Exit Function
Else
findFile2 = indexFD.SelectedItems(1)
End If
Set indexFD = Nothing
'------------------------------------------------------------
End Function
Function findFile3(fileName As String) As String
Dim indexFD As FileDialog
Dim srcIndex As Workbook
Dim ynCanx As Integer
RetrySub:
'File Dialog Setup and Return
Set indexFD = Application.FileDialog(msoFileDialogFilePicker)
'------------------------------------------------------------
indexFD.Title = "Select the " & fileName & " for use"
'Set Index file Filters
indexFD.Filters.Clear
indexFD.InitialFileName = ActiveWorkbook.Path
indexFD.Filters.Add "Project Schedules", "*.mpp"
indexFD.FilterIndex = 1
indexFD.ButtonName = "Choose &File"
If indexFD.Show <> -1 Then
Exit Function
Else
findFile3 = indexFD.SelectedItems(1)
End If
Set indexFD = Nothing
'------------------------------------------------------------
End Function
Function findFile4(fileName As String) As String
Dim indexFD As FileDialog
Dim srcIndex As Workbook
Dim ynCanx As Integer
RetrySub:
'File Dialog Setup and Return
Set indexFD = Application.FileDialog(msoFileDialogFilePicker)
'------------------------------------------------------------
indexFD.Title = "Select the " & fileName & " for use"
'Set Index file Filters
indexFD.Filters.Clear
indexFD.InitialFileName = ActiveWorkbook.Path
indexFD.Filters.Add "Project Schedules", "*.mpp"
indexFD.FilterIndex = 1
indexFD.ButtonName = "Choose &File"
If indexFD.Show <> -1 Then
Exit Function
Else
findFile4 = indexFD.SelectedItems(1)
End If
Set indexFD = Nothing
'------------------------------------------------------------
End Function
Sub Refresh_All()
Update_Schedule
Exit Sub
ThisWorkbook.RefreshAll
Application.CalculateUntilAsyncQueriesDone
If ThisWorkbook.Sheets("Data").Range("I3").Value < 0 Then _
ThisWorkbook.Sheets("TestBurndown").Shapes("VAR").DrawingObject.Font.Color = vbRed Else _
ThisWorkbook.Sheets("TestBurndown").Shapes("VAR").DrawingObject.Font.Color = vbBlack
End Sub
-
Jul 7th, 2018, 07:43 PM
#2
Re: Loop to paste new file location in the next cell below previous.
here is basic code for the first part, tested and works correctly to create clickable hyperlinks
Code:
Sub mmp()
Dim sht As Worksheet, r As Range
Set sht = Sheets("mysheet") ' change worksheet name
Set fd = Application.FileDialog(msoFileDialogOpen)
With fd
.InitialFileName = ActiveWorkbook.Path ' change path to suit
.Filters.Add "Project files", "*.mpp" 'check the extension of project files
.FilterIndex = .Filters.Count
.AllowMultiSelect = True
'make the file dialog visible to the user
intchoice = .Show
If intchoice = 0 Then Exit Sub ' no files chosen
For i = 1 To .SelectedItems.Count
sht.Hyperlinks.Add sht.Cells(i, 1), "file://" & .SelectedItems(i)
Next ' filename
End With
End Sub
if you want to add more links to the same worksheet, you would need to add the number of used rows to sht.cells(i, 1)
i believe that you should not add the filter each time it is run as it will keep adding additional filters even if they are the same, alternatively delete the added filters each time
Last edited by westconn1; Jul 7th, 2018 at 08:08 PM.
i do my best to test code works before i post it, but sometimes am unable to do so for some reason, and usually say so if this is the case.
Note code snippets posted are just that and do not include error handling that is required in real world applications, but avoid On Error Resume Next
dim all variables as required as often i have done so elsewhere in my code but only posted the relevant part
come back and mark your original post as resolved if your problem is fixed
pete
-
Jul 9th, 2018, 08:19 AM
#3
Thread Starter
Junior Member
Re: Loop to paste new file location in the next cell below previous.
Hey Pete,
This is great! Works smoothly actually even if I keep the filter consistent. I appreciate it! I am going to try and expand on It and will more than likely post again for more help as I'm learning! Thanks!
Posting Permissions
- You may not post new threads
- You may not post replies
- You may not post attachments
- You may not edit your posts
-
Forum Rules
|
Click Here to Expand Forum to Full Width
|