Macro to copy files referenced in hyperlinked cells to another folder

[Brawnystaff]

I am looking to copy files referenced as hyperlinks in an Excel worksheet to a directory specified in the macro. Attached is the Excel file (the spreadsheet is currently in the same directory as the referenced files).

Ideally, I would like to select a range of cells with hyperlinks and only have those selected hyperlinked files copied over. I tried few scripts by Googling answers, but none seemed to work. Any ideas? Thanks..

[patel45]

Sub copylistselectedfiles()
oldpath = ThisWorkbook.Path
newpath = "C:\test"
For Each r In Selection
    FileCopy oldpath & r.Value, newpath & "\" & r
Next
End Sub

[Brawnystaff]

Made a slight correction to your script and go it to work. Thanks.

Sub copylistselectedfiles()
oldpath = ThisWorkbook.Path
newpath = "C:\Test"
For Each r In Selection
    FileCopy oldpath & "\" & r.Value, newpath & "\" & r
Next
End Sub

[Brawnystaff]

I have made some additional changes to the code for further refinement and it works, so long as the spreadsheet is saved in the same directory as the files it hyperlinks to.

However, if the spreadsheet references files outside the current directory, it does not work (e.g. hyperlink show Travel/chicago.docx, with the cell showing chicago.docx). Any ideas how to modify it to work with file inside a directory as well as sub-directories? Thx..

Latest code is below...

Sub CopyListSelectedFiles()
'Copy selected hyperlinked files to selected destination folder
Dim oldpath As String
Dim newpath As String
Dim rng As Range
Dim r As Object
oldpath = ActiveWorkbook.path
Set rng = Selection.SpecialCells(xlCellTypeVisible)
With Application.FileDialog(msoFileDialogFolderPicker)
   .AllowMultiSelect = False
   .Show
   On Error Resume Next
   newpath = .SelectedItems(1)
   err.Clear
   On Error GoTo 0
 End With
 On Error Resume Next
For Each r In rng
    FileCopy oldpath & "\" & r.Value, newpath & "\" & r
Next
MsgBox "Files Copied to " & newpath
End Sub

[patel45]

attach please a new sample file for testing

[HaHoBe]

Hi, Brawnystaff,

from what I understand: maybe alter the hyperlinks to point to the new directory as they still should point to the old directory?

Ciao,
Holger

[Brawnystaff]

Thanks HaHoBe..rather than put the path in each hyperlink, I just put it in cell A1 and reference it in the macro. Updated code below. Will mark this as solved..

Sub CopyListSelectedFiles()
'Copy selected hyperlinked files to selected destination folder
Dim oldpath As String
Dim newpath As String
Dim rng As Range
Dim r As Object
oldpath = Range("A1")
If InStr(1, oldpath, "\", vbTextCompare) Then
Set rng = Selection.SpecialCells(xlCellTypeVisible)
Else
MsgBox "Ensure cell A1 has path of files" & vbNewLine & "e.g. C:\My Files\"
GoTo Nope
End If
With Application.FileDialog(msoFileDialogFolderPicker)
   .AllowMultiSelect = False
   .Show
   On Error Resume Next
   newpath = .SelectedItems(1)
   err.Clear
   On Error GoTo 0
 End With
 On Error Resume Next
For Each r In rng
    FileCopy oldpath & r.Value, newpath & "\" & r
Next
MsgBox "Selected Files Copied to " & newpath
Nope:
End Sub