Consulting

Results 1 to 3 of 3

Thread: Solved: Dynamic File Path - Code Tweak?!

  1. #1
    VBAX Regular
    Joined
    Aug 2009
    Posts
    44
    Location

    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:

     
    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:

     
        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.

  2. #2
    VBAX Regular
    Joined
    Aug 2009
    Posts
    44
    Location
    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:

    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


  3. #3
    VBAX Regular
    Joined
    Aug 2009
    Posts
    44
    Location
    Problem solved.

     
    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

Posting Permissions

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