Create Loop to read range of cells and open each file and pull columns

[benrbeau]

Good Morning Everyone,

I'm looking for some help in making this code work. Pete (Westconn) was able to help me with the first part as far as easily browsing and saving multiple file locations with the first bit of code. Now, I need help to create a loop that will run the contents of the second part (Update_Schedule) based on every cell in a specific range that has the hyperlink within it. Intent is to grab all the needed columns from Project (.mpp) and dump them into a spreadsheet "Schedule". I want to try and learn so on the Update_Schedule coding could you please provide a few notes along with a specific loop type you'd use. I'm wondering if it's as simple as a Boolean saying something around the lines of If Range is not "" then run the loop to pull the data. Another concern is if it will stack on top of eachother within the table or go to the next file, then start from the beginning and erase over.

[/Sub mmp()
Dim sht As Worksheet, r As Range
    Set sht = Sheets("TestBurndown")    '  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
'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
End Sub

Function Update_Schedule() As Boolean

Dim apProject, prSched, nTask, nTimePhaseItem As Object, strPath As String
Dim rsOrg, colDept As Object, strDept(), strRes() As String, i As Integer, blSave As Boolean

strPath = ThisWorkbook.Sheets("TestBurndown").Range("A1").Value

Set apProject = CreateObject("MSProject.Application")
Set prSched = CreateObject("MSProject.Project")
Set colDept = CreateObject("Scripting.Dictionary")

On Error GoTo NoSched

apProject.FileOpenEx (strPath)

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.UniqueID
                    .Range.Cells(1, 2).Value = nTask.Text27
                    .Range.Cells(1, 3).Value = nTask.Name
                    If nTask.BaselineFinish = "NA" Then
                        nTask.BaselineFinish = nTask.Finish
                        blSave = True
                    End If
                    .Range.Cells(1, 4).Value = Format(nTask.BaselineFinish, "mm/dd/yyyy")
                    .Range.Cells(1, 5).Value = Format(nTask.Finish, "mm/dd/yyyy")
                    .Range.Cells(1, 6).Value = nTask.PercentComplete / 100
                    .Range.Cells(1, 7).Value = nTask.Text1 'Schedule Template lists as 'Phase'
                    .Range.Cells(1, 8).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:

MsgBox "Error connecting to the Project file linked at: " & Chr(13) & strPath, vbOKOnly, "Reconnect Schedule"
Update_Schedule = False
Set prSched = Nothing

End Function


Sub Refresh_All()

If Not Update_Schedule Then Exit Sub
ThisWorkbook.RefreshAll

End Sub

[westconn1]

does this code do what you want for one project?

[benrbeau]

Right now it gives me an error that the link is no accessable in "A1" to actually open.

strPath = ThisWorkbook.Sheets("TestBurndown").Range("A1").Value

[westconn1]

give more details
is there a link in A1?
do your links start in row 1 and are continuous to the last row?

i assumed from your original thread that you want all the results in columns of the worksheet containing the hyperlinks, is this correct?
are you only working with 1 worksheet?

Sub eachrow()
Dim cel As Range, apProject As Object
    Set apProject = CreateObject("MSProject.Application")
    With Worksheets("mysheet")     ' change sheetname to suit
        For Each cel In .Range("a:a")
            If IsEmpty(cel) Then Exit For ' stop at first empty row
            apProject.FileOpenEx cel
            o = 1
            For Each nTask In apProject.Tasks
                If Not nTask Is Nothing Then
                    cel.Offset(, o) = nTask.UniqueID
                    cel.Offset(, o + 1) = nTask.Name
                    ' you need to put whatever information you want from the task in here
                    ' use cel.offset(o + x) = for each item of information
                    o = o + 2   ' change the 2 to 1 more than the number of items from above
                                     ' or add an additional 1 to leave a blank column between tasks
                End If
            Next
            apProject.FileCloseEx False ' do not save the project
        Next
    End With
End Sub

as i mentioned elsewhere, i do not use project, nor have it installed to test with
the project part of the code is just taken from the code you posted above, i can only assume it should work, but i have not tested at all
if you just run the code exactly as posted (except for sheet name), you should see some result in your worksheet, you can then add other items to get the result you want
make sure your links start in row 1, else some change will be need for the range to process, not to include headers or whatever, for testing just remove all rows above the links, we can fix the range later

[benrbeau]

Good Afternoon Pete,

I will be testing the code you put in there soon but to answer your questions:
1. There is a link in A1 and going down based off of how many projects I select. The links will be placed only based off of the number of projects I multiple select. (I guess this answers both of your questions).
The ultimate goal is to have MSProject.Application open the hyperlink in A1 and below (if there is a hyperlink), open them all and then paste the specified columns in the worksheet "TestBurndown". I will see how the code you wrote helps and tweek it and see if it's functional. I'll provide a lot more clarity and detail once I've gotten the chance to run it.

[westconn1]

please note that the code i posted to get the files to hyperlinks does nothing to check if the file is already listed in the worksheet, depending how you use it you could select and add the same file multiple times

it is possible you would need to change to

For Each nTask In apProject.activeproject.Tasks

if you get an error there, try the change

[benrbeau]

The code is working well minus the fact that the information get's overwritten by the next project file data pulled. Wonder if there is a way to make the list continue form where it left off?

Sub mmp()
Dim sht As Worksheet, r As Range
    Set sht = Sheets("TestBurndown")    '  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
'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
End Sub
Sub eachrow()
Dim cel As Range, apProject As Object
    Set apProject = CreateObject("MSProject.Application")
    With Worksheets("TestBurndown")     ' change sheetname to suit
        For Each cel In .Range("a:a")
            If IsEmpty(cel) Then Exit For ' stop at first empty row
            apProject.FileOpenEx cel
            o = 1
            For Each nTask In apProject.activeproject.Tasks
                If Not nTask Is Nothing Then
                    cel.Offset(o, 7).Value = nTask.UniqueID
                    cel.Offset(o, 8).Value = nTask.Name
                    cel.Offset(o, 9).Value = Format(nTask.BaselineFinish, "mm/dd/yyyy")
                    cel.Offset(o, 10).Value = Format(nTask.Finish, "mm/dd/yyyy")
                    cel.Offset(o, 11).Value = nTask.PercentComplete / 100
                    o = o + 1   ' change the 2 to 1 more than the number of items from above
                                     ' or add an additional 1 to leave a blank column between tasks
                End If
            Next
            apProject.FileCloseEx False ' do not save the project
        Next
    End With
End Sub

[westconn1]

overwritten by the next project file data pulled. Wonder if there is a way to make the list continue form where it left off?

yes read the notes, your offsets need to be fixed

the information for all tasks for each project should be on the same row, else they will not align with the project file, so you do not need a row offset at all, we just need to offset the columns, you can use .offset(0, o), but i just leave the row offset empty for 0, .offset(, o)

to start the first task at column 7(as your code above) you should set an initial value of o = 6 (column 1 + offset of 6), so that part of the code should now look like

            o = 6
            For Each nTask In apProject.activeproject.Tasks
                If Not nTask Is Nothing Then
                    cel.Offset(, o).Value = nTask.UniqueID   ' column 7 for the first task
                    cel.Offset(, o + 1).Value = nTask.Name
                    cel.Offset(, o + 2).Value = Format(nTask.BaselineFinish, "mm/dd/yyyy")
                    cel.Offset(, o + 3).Value = Format(nTask.Finish, "mm/dd/yyyy")
                    cel.Offset(, o + 4).Value = nTask.PercentComplete / 100   'column 11 for first task
                    o = o + 5 + 1   ' +5 = 1 more than the number of items from above so the next data would be column 12
                                           '   + 1 to leave a blank column between tasks, so 2nd task would start on column 13, that is 6 columns for each task
                End If
            Next

[benrbeau]

Good Morning Pete,

So I tried out the code you provided. It seems that the issue is that it is going to new columns on to the right. Essentially I want the link for .mpp to put the "nTask.Name into a column, Format(nTask.BaselineFinish) and so on into columns next to eachother. Then when the data is pulled it goes down into the rows. For some reason when I run the code it puts everything in the first 2 rows starting from the correct column that I want, but it pastes all the information to other columns rather then down the rows in the correct column it falls under.

[westconn1]

i am not sure i understand correctly

are all the .mpp files being processed?
or do you want each task to be on a separate row?
i do not see how tasks for other projects can be on the row of some other project
all the tasks for each project should be in the same row

post the code as updated and a screenshot or the result if possible

[benrbeau]

Good Morning Pete,

Sub eachrow()
Dim cel As Range, apProject As Object
    Set apProject = CreateObject("MSProject.Application")
    With Worksheets("TestBurndown")     ' change sheetname to suit
        For Each cel In .Range("a:a")
            If IsEmpty(cel) Then Exit For ' stop at first empty row
            apProject.FileOpenEx cel
            o = 6
            For Each nTask In apProject.activeproject.Tasks
                If Not nTask Is Nothing Then
                    cel.Offset(, o).Value = nTask.UniqueID
                    cel.Offset(, o + 1).Value = nTask.Name
                    cel.Offset(, o + 2).Value = Format(nTask.BaselineFinish, "mm/dd/yyyy")
                    cel.Offset(, o + 3).Value = Format(nTask.Finish, "mm/dd/yyyy")
                    cel.Offset(, o + 4).Value = nTask.PercentComplete / 100
                    o = o + 5 + 1   ' change the 2 to 1 more than the number of items from above
                                     ' or add an additional 1 to leave a blank column between tasks
                End If
            Next
            apProject.FileCloseEx False ' do not save the project
        Next
    End With
End Sub

This is the code you gave me that puts all of the tasks in additional columns.

Sub eachrow()
Dim cel As Range, apProject As Object
    Set apProject = CreateObject("MSProject.Application")
    With Worksheets("TestBurndown")     ' change sheetname to suit
        For Each cel In .Range("a:a")
            If IsEmpty(cel) Then Exit For ' stop at first empty row
            apProject.FileOpenEx cel
            o = 1
            For Each nTask In apProject.activeproject.Tasks
                If Not nTask Is Nothing Then
                    cel.Offset(o, 7).Value = nTask.UniqueID
                    cel.Offset(o, 8).Value = nTask.Name
                    cel.Offset(o, 9).Value = Format(nTask.BaselineFinish, "mm/dd/yyyy")
                    cel.Offset(o, 10).Value = Format(nTask.Finish, "mm/dd/yyyy")
                    cel.Offset(o, 11).Value = nTask.PercentComplete / 100
                    o = o + 1   ' change the 2 to 1 more than the number of items from above
                                     ' or add an additional 1 to leave a blank column between tasks
                End If
            Next
            apProject.FileCloseEx False ' do not save the project
        Next
    End With
End Sub

This is more of less the output I'm trying to look for. The issue I have is that when the next file is opened and read through and pasted it pastes over the first projects contents instead of continuing down below.

[westconn1]

This is more of less the output I'm trying to look for.

this appears, from what i can see in the image, that you want each task on a separate row, if that is correct, i would think that you would want to inset a row between each file for each additional task?

if this is correct i can fix the code to do like that

[benrbeau]

Good Morning Pete,

Ultimately I want the layout exactly same as the second portion I showed. But when the new file is opened and he data is copied it pastes directly under in the same format.

[westconn1]

so you do not need the task data to align with the file name?

[benrbeau]

so you do not need the task data to align with the file name?

Ultimately I just want all the content from each file in the same columns because I'm going to create a pull that will pull a table from another view in Microsoft Project. Ultimately I just want all the tasks dumped under eachother in the same column regardless of the project. I'm trying to create a file that can pull as many project files as I need, dump the specified columns into the spreadsheet then pull hours (working on this later). Eventually it will create a sand chart to show all the resource hours from ALL the projects. So I just need the next file data to show up under the predecessing file and continue pasting under it.

[benrbeau]

so you do not need the task data to align with the file name?

Ultimately I just want all the content from each file in the same columns because I'm going to create a pull that will pull a table from another view in Microsoft Project. Ultimately I just want all the tasks dumped under eachother in the same column regardless of the project. I'm trying to create a file that can pull as many project files as I need, dump the specified columns into the spreadsheet then pull hours (working on this later). Eventually it will create a sand chart to show all the resource hours from ALL the projects. So I just need the next file data to show up under the predecessing file and continue pasting under it.

[westconn1]

looks like i totally misunderstood your desired result, try like

Sub eachrow()
Dim cel As Range, apProject As Object
    Set apProject = CreateObject("MSProject.Application")
    rw = 1
    With Worksheets("TestBurndown")     ' change sheetname to suit
        For Each cel In .Range("a:a")
            If IsEmpty(cel) Then Exit For ' stop at first empty row
            apProject.FileOpenEx cel
            
            For Each nTask In apProject.activeproject.Tasks
                If Not nTask Is Nothing Then
                    cel.Offset(rw, 7).Value = nTask.UniqueID
                    cel.Offset(rw, 8).Value = nTask.Name
                    cel.Offset(rw, 9).Value = Format(nTask.BaselineFinish, "mm/dd/yyyy")
                    cel.Offset(rw, 10).Value = Format(nTask.Finish, "mm/dd/yyyy")
                    cel.Offset(rw, 11).Value = nTask.PercentComplete / 100
                   rw = rw + 1
                End If
            Next
            apProject.FileCloseEx False ' do not save the project
        Next
    End With
End Sub