Solved: Dynamic File Path - Code Tweak?!

Afternoon all,

I have the the following code which matches a value and paste the corresponding enteries as specified into adjacent cells:

Code:

---


Sub Transfer()
    Dim EmpId As Range
    Dim WB As Workbook
    Dim ws As Worksheet
    Dim c As Range
    Dim rng As Range
    Dim MyInput As String
    Application.EnableEvents = False
    Application.ScreenUpdating = False
   
    On Error Resume Next
    Set WB = Workbooks("Talent Tool.xls")
    MyInput = InputBox("Transfer Data To", _
    "Enter Talent Tool Name", "Enter text HERE")
    If MyInput = "" Or MyInput = "Enter text HERE" Then Exit Sub
   
    If WB Is Nothing Then
        Set WB = Workbooks.Open("\\mkfile1\Reports\All\Central\" & MyInput & ".xls")
    End If
   
    Set ws = WB.Sheets("People_Data")
    With ThisWorkbook.Sheets("People_Data")
        Set rng = Range(.Cells(12, 3), .Cells(Rows.Count, 3).End(xlUp))
    End With
   
    For Each EmpId In rng
        Set c = ws.Columns(3).Find(EmpId.Value, lookat:=xlWhole)
        If Not c Is Nothing Then
            EmpId.Offset(, 1).Resize(, 5).Copy
            c.Offset(, 1).PasteSpecial xlPasteValues
            EmpId.Offset(, 7).Resize(, 6).Copy
            c.Offset(, 7).PasteSpecial xlPasteValues
            EmpId.Offset(, 14).Resize(, 7).Copy
            c.Offset(, 14).PasteSpecial xlPasteValues
        End If
   
    Next
   
    Set ws = WB.Sheets("Successors_for_Roles")
    With ThisWorkbook.Sheets("Successors_for_Roles")
        Set rng = Range(.Cells(12, 3), .Cells(Rows.Count, 3).End(xlUp))
    End With
   
    For Each EmpId In rng
        Set c = ws.Columns(3).Find(EmpId.Value, lookat:=xlWhole)
        If Not c Is Nothing Then
            EmpId.Offset(, 1).Resize(, 5).Copy
            c.Offset(, 1).PasteSpecial xlPasteValues
            EmpId.Offset(, 7).Resize(, 7).Copy
            c.Offset(, 7).PasteSpecial xlPasteValues
        End If
   
    Next
   
    WB.Save
    WB.Close
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    MsgBox ("Data Transferred to Master")
End Sub

---

What I am trying to do is incorporate the following:

Code:

---


    MyPaths = Array("Central\", "Northern\", "Southern\")
    For Each Pth In MyPaths
        Pth = "\\mkfile1\Reports\All\" & Pth

---

Unfortunately I keep hitting a brick wall.

The reason I want to amend the code is that there are three possible folders in which the file (MyInput) may reside. Instead of declaring a specific file path, I'd like to make it dynamic?!

Any help would be much appreciated.

Thanks.

I've half solved the problem; however is there anyway I can suppress the file not found message?! Unless I’m mistaken the Next Pth prompt is in it’s logical position as far as I can tell.

I've tweaked the code to read:

Code:

---

Sub Transfer()
    Dim EmpId As Range
    Dim WB As Workbook
    Dim ws As Worksheet
    Dim c As Range
    Dim rng As Range
    Dim Pth As Variant, MyPaths As Variant
    Dim MyInput As String
    Application.EnableEvents = False
    Application.ScreenUpdating = False
   
    On Error Resume Next
    Set WB = Workbooks("Talent Tool.xls")
   
    MyInput = InputBox("Transfer Data To", _
    "Enter Talent Tool Name", "Enter text HERE")
    If MyInput = "" Or MyInput = "Enter text HERE" Then Exit Sub
 
    MyPaths = Array("Central\", "Northern\", "Southern\")
    For Each Pth In MyPaths
    Pth = "\\mkfile1\Reports\All\Area\" & Pth
    MyFile = Dir(Pth & "" & MyInput & ".xls")
   
    If WB Is Nothing Then
        Set WB = Workbooks.Open(Pth & "" & MyInput & ".xls")
    End If
   
    MyFile = Dir
    Next Pth

    Set ws = WB.Sheets("People_Data")
    With ThisWorkbook.Sheets("People_Data")
        Set rng = Range(.Cells(12, 3), .Cells(Rows.Count, 3).End(xlUp))
    End With
   
    For Each EmpId In rng
        Set c = ws.Columns(3).Find(EmpId.Value, lookat:=xlWhole)
        If Not c Is Nothing Then
            EmpId.Offset(, 1).Resize(, 5).Copy
            c.Offset(, 1).PasteSpecial xlPasteValues
            EmpId.Offset(, 7).Resize(, 6).Copy
            c.Offset(, 7).PasteSpecial xlPasteValues
            EmpId.Offset(, 14).Resize(, 7).Copy
            c.Offset(, 14).PasteSpecial xlPasteValues
        End If
   
    Next
   
    Set ws = WB.Sheets("Successors_for_Roles")
    With ThisWorkbook.Sheets("Successors_for_Roles")
        Set rng = Range(.Cells(12, 3), .Cells(Rows.Count, 3).End(xlUp))
    End With
   
    For Each EmpId In rng
        Set c = ws.Columns(3).Find(EmpId.Value, lookat:=xlWhole)
        If Not c Is Nothing Then
            EmpId.Offset(, 1).Resize(, 5).Copy
            c.Offset(, 1).PasteSpecial xlPasteValues
            EmpId.Offset(, 7).Resize(, 7).Copy
            c.Offset(, 7).PasteSpecial xlPasteValues
        End If
   
    Next
   
    WB.Save
    WB.Close
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    MsgBox ("Data Transferred to Master")
   
End Sub

---

Problem solved.

Code:

---


Sub Transfer()
    Dim EmpId As Range
    Dim WB As Workbook
    Dim ws As Worksheet
    Dim c As Range
    Dim rng As Range
    Dim Pth As Variant, MyPaths As Variant
    Dim MyInput As String
    Application.EnableEvents = False
    Application.ScreenUpdating = False
   
    On Error Resume Next
    Set WB = Workbooks("Talent Tool.xls")
   
    MyInput = InputBox("Transfer Data To", _
    "Enter Talent Tool Name", "Enter text HERE")
    If MyInput = "" Or MyInput = "Enter text HERE" Then Exit Sub
 
    MyPaths = Array("Central\", "Northern\", "Southern\")
    For Each Pth In MyPaths
    Pth = "\\mkfile1\Reports\All\Area\" & Pth
    MyFile = Dir(Pth & "" & MyInput & ".xls")
   
    If WB Is Nothing Then
        Set WB = Workbooks.Open(Pth & "" & MyInput & ".xls")
    End If
   
    MyFile = Dir
    On Error Resume Next
    Next Pth
 
    Set ws = WB.Sheets("People_Data")
    With ThisWorkbook.Sheets("People_Data")
        Set rng = Range(.Cells(12, 3), .Cells(Rows.Count, 3).End(xlUp))
    End With
   
    For Each EmpId In rng
        Set c = ws.Columns(3).Find(EmpId.Value, lookat:=xlWhole)
        If Not c Is Nothing Then
            EmpId.Offset(, 1).Resize(, 5).Copy
            c.Offset(, 1).PasteSpecial xlPasteValues
            EmpId.Offset(, 7).Resize(, 6).Copy
            c.Offset(, 7).PasteSpecial xlPasteValues
            EmpId.Offset(, 14).Resize(, 7).Copy
            c.Offset(, 14).PasteSpecial xlPasteValues
        End If
   
    Next
   
    Set ws = WB.Sheets("Successors_for_Roles")
    With ThisWorkbook.Sheets("Successors_for_Roles")
        Set rng = Range(.Cells(12, 3), .Cells(Rows.Count, 3).End(xlUp))
    End With
   
    For Each EmpId In rng
        Set c = ws.Columns(3).Find(EmpId.Value, lookat:=xlWhole)
        If Not c Is Nothing Then
            EmpId.Offset(, 1).Resize(, 5).Copy
            c.Offset(, 1).PasteSpecial xlPasteValues
            EmpId.Offset(, 7).Resize(, 7).Copy
            c.Offset(, 7).PasteSpecial xlPasteValues
        End If
   
    Next
   
    WB.Save
    WB.Close
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    MsgBox ("Data Transferred to Master")
   
End Sub

---