PDA

View Full Version : Solved: Dynamic File Path - Code Tweak?!



SDave
07-12-2010, 07:22 AM
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\ (file://mkfile1/General/HR)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\ (file://mkfile1/Regional/General/HR)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.

SDave
07-12-2010, 08:58 AM
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\ (file://mkfile1/Regional/General/HR)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

SDave
07-12-2010, 12:35 PM
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\ (file://\\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