dcsimg
Results 1 to 3 of 3
  1. #1

    Thread Starter
    New Member
    Join Date
    Jul 2018
    Posts
    13

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

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

    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

  3. #3

    Thread Starter
    New Member
    Join Date
    Jul 2018
    Posts
    13

    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
  •  



Featured


Click Here to Expand Forum to Full Width