dcsimg
Results 1 to 17 of 17

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

  1. #1

    Thread Starter
    Junior Member
    Join Date
    Jul 2018
    Posts
    16

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

    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.

    Code:
    [/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

  2. #2
    PowerPoster
    Join Date
    Dec 2004
    Posts
    23,777

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

    does this code do what you want for one project?
    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

  3. #3

    Thread Starter
    Junior Member
    Join Date
    Jul 2018
    Posts
    16

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

    Right now it gives me an error that the link is no accessable in "A1" to actually open.
    Code:
    strPath = ThisWorkbook.Sheets("TestBurndown").Range("A1").Value

  4. #4
    PowerPoster
    Join Date
    Dec 2004
    Posts
    23,777

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

    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?

    Code:
    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
    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

  5. #5

    Thread Starter
    Junior Member
    Join Date
    Jul 2018
    Posts
    16

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

    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.

  6. #6
    PowerPoster
    Join Date
    Dec 2004
    Posts
    23,777

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

    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
    Code:
    For Each nTask In apProject.activeproject.Tasks
    if you get an error there, try the change
    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

  7. #7

    Thread Starter
    Junior Member
    Join Date
    Jul 2018
    Posts
    16

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

    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?
    Code:
    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

  8. #8
    PowerPoster
    Join Date
    Dec 2004
    Posts
    23,777

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

    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


    Code:
                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
    Last edited by westconn1; Jul 13th, 2018 at 05:41 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

  9. #9

    Thread Starter
    Junior Member
    Join Date
    Jul 2018
    Posts
    16

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

    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.

  10. #10
    PowerPoster
    Join Date
    Dec 2004
    Posts
    23,777

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

    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
    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

  11. #11

    Thread Starter
    Junior Member
    Join Date
    Jul 2018
    Posts
    16

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

    Good Morning Pete,

    Code:
    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
    Name:  Test.jpg
Views: 39
Size:  4.9 KB

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

    Code:
    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
    Name:  test2.jpg
Views: 38
Size:  35.9 KB

    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.

  12. #12
    PowerPoster
    Join Date
    Dec 2004
    Posts
    23,777

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

    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
    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

  13. #13

    Thread Starter
    Junior Member
    Join Date
    Jul 2018
    Posts
    16

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

    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.

  14. #14
    PowerPoster
    Join Date
    Dec 2004
    Posts
    23,777

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

    so you do not need the task data to align with the file name?
    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

  15. #15

    Thread Starter
    Junior Member
    Join Date
    Jul 2018
    Posts
    16

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

    Quote Originally Posted by westconn1 View Post
    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.

  16. #16

    Thread Starter
    Junior Member
    Join Date
    Jul 2018
    Posts
    16

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

    Quote Originally Posted by westconn1 View Post
    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.

  17. #17
    PowerPoster
    Join Date
    Dec 2004
    Posts
    23,777

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

    looks like i totally misunderstood your desired result, try like
    Code:
    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
    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

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •  



Featured


Click Here to Expand Forum to Full Width