VBA - Copy Out Files

[opazzo]

Hi there,

I have an excel spreadhseet with hyperlinks to electronic files. These links are created dynamically based on the value of the cell, using some VBA code, ie not hard-linked. This is working fine (thanks to the help of this board).

Now I am trying to improve my system and I would like to have the ability to filter my list (using autofilter) and click a button to copy out (extract) only those files that have been filtered or selected.

I can figure out how to copy files and get to choose the destination folder but I don't manage to select the files (based on the hyperlink value). Oh and of course all files are located in different folders (reason why I am using a dynamic hyperlink).

I hope this is clear enough for you to provide some guidance, if not please let me know.

Thanks

 

[opazzo]

Up. Anybody please ?

 

[opazzo]

Some guidance please, I am really lost on this one. Let me know if posting my table would help. Thanks

 

[opazzo]

Bump

 

[opazzo]

OK here are some more details, hope it will help to understand my problem.

As I explained I have a list of documents and a VBA code used to dynamically associate these document numbers to the corresponding electronic files (pdf). I use Excel 2003 so I can use the Application.FileSearch. Here is the code for that :

--------------

Const transcol As String = "A"

If Target.Count > 1 Then Exit Sub
If Target.Column <> Columns(transcol).Column Then Exit Sub
If Target.Row < 6 Then Exit Sub
If IsEmpty(Target) Then Exit Sub
Cancel = True
FPath = "\\shareddrive\folder\"

fName = ActiveCell.Value
fName = Application.WorksheetFunction.Substitute(fName, "-", "")
fName = fName & "_" & ActiveCell.Offset(0, 1).Value & ".pdf"

With Application.FileSearch
.NewSearch
.LookIn = FPath
.SearchSubFolders = True
.Filename = fName
If .Execute(SortBy:=msoSortByFileName, _
SortOrder:=msoSortOrderAscending) > 0 Then
Fil = .FoundFiles(1)
Else
MsgBox "There were no files found."
Exit Sub
End If
End With

ActiveWorkbook.FollowHyperlink Fil
On Error GoTo oops
Exit Sub

oops:

eMsg = MsgBox("Error !", vbExclamation)
Exit Sub

End Sub
-----------------

My question is how to set-up a macro that would copy out (extract) the selected files from the original location (shared drive) to my computer for instance.

What I do not manage to figure out is how to select and capture the path of different files at once, given that the links are created dynamically (cannot really change that).

Once this "list" is captured a Filecopy command should suffice to do the trick.

Appreciate any help with this.

 

[opazzo]

Bump....

 

[opazzo]

I eventually managed to find a solution to my problem... May be not the best methodology but works for me.

I post the code here for anybody that may be interested or having a similar question. Hope this will help. Of course any suggestion for improvement is welcome.

It would be interesting to see how the Application.FileSearch could be replaced with something else for Excel 2007/10 users.


-----------------------------------

Dim dest As String

Option Explicit

Sub CopyOut()

Dim Scell As Range
Dim Col As Integer
Dim Rw As Integer
Dim FPath As String
Dim fName As String
Dim Fil As String
Dim i As Long
Dim eMsg As String

GetFolder ("c:/")
dest = dest + "/"

Col = ActiveCell.Column
Rw = ActiveCell.Row

If Col > 1 Then Exit Sub
If Rw < 6 Then Exit Sub

FPath = "\\shareddrive\source folder\

For Each Scell In Selection

fName = Scell.Value
fName = Application.WorksheetFunction.Substitute(fName, "-", "")
fName = fName & "_" & ActiveCell.Offset(0, 1).Value & ".pdf"

With Application.FileSearch
.NewSearch
.LookIn = FPath
.SearchSubFolders = True
.Filename = fName
If .Execute(SortBy:=msoSortByFileName, _
SortOrder:=msoSortOrderAscending) > 0 Then
Fil = .FoundFiles(1)
Else
MsgBox "There were no files found."
Exit Sub
End If
End With
FileCopy Fil, dest + fName

Next

eMsg = MsgBox("Files Copied. Please verify all files have been copied", vbInformation)

End Sub

Function GetFolder(strPath As String) As String
Dim fldr As FileDialog
Dim sItem As String
Dim sInitDir As String
sInitDir = CurDir ' Store initial directory
Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
With fldr
.Title = "Select a Folder"
.AllowMultiSelect = False
.InitialFileName = strPath
If .Show <> -1 Then GoTo NextCode
sItem = .SelectedItems(1)
End With
NextCode:
' Reset directory before exit
ChDrive sInitDir ' Return to the Initial Drive
ChDir sInitDir ' Resets directory for Initial Drive
GetFolder = sItem
Set fldr = Nothing
dest = sItem
End Function