Sub MainMacro()
'This is the macro to run for all things
Application.ScreenUpdating = False
'CHANGE THIS LINE
'===============
'What Range has hyperlinks originally?
Call MoveFilesAndFolders(Range("A1:A5"))
'===============
MsgBox "Operation complete!"
Application.ScreenUpdating = True
End Sub
Private Sub MoveFilesAndFolders(myRange As Range)
Dim c As Range
Dim destPath As String
Dim sourcePath As String
Dim fName As String
'CHANGE THIS LINE
'===============
'Where are we moving everything to?
destPath = "C:\Users\swami\Desktop\Dest Files Move"
'===============
'Error checking
If Right(destPath, 1) <> "\" Then
destPath = destPath & "\"
End If
For Each c In myRange
sourcePath = ""
On Error Resume Next
sourcePath = c.Hyperlinks(1).Address
On Error GoTo 0
If sourcePath = "" Then
MsgBox c.Address(False, False) & " does not have a hyperlink." & vbNewLine & "Moving to next cell..."
GoTo nextCell
End If
'Check if it's a file or folder
fName = Dir(sourcePath)
If fName = "" Then
'It's a folder
Call MakeLinks(sourcePath, c.Offset(0, 1).Value)
'Else
'It's a file
'FileCopy sourcePath, destPath & c.Offset(, 1).Value & " " & fName
ElseIf fName = "*.xls" Or fName = "*.xlsx" Or fName = "*.xlsm" Then
FileCopy sourcePath, destPath & c.Offset(, 1).Value & " " & fName
End If
nextCell:
Next c
End Sub
Private Sub MakeLinks(fPath As String, newNum As String)
Dim objFSO As Object
Dim objFolder As Object
Dim objFile As Object
Dim i As Integer
'Pick some column out of the way to put links.
'Currently using col Z
Const myCol As Long = 26
'Create an instance of the FileSystemObject
Set objFSO = CreateObject("Scripting.FileSystemObject")
'Get the folder object
Set objFolder = objFSO.GetFolder(fPath)
i = 1
'loops through each file in the directory
For Each objFile In objFolder.Files
'create hyperlink in selected cell
ActiveSheet.Hyperlinks.Add Anchor:=Cells(i, myCol), Address:= _
objFile.Path, TextToDisplay:=objFile.Name
Cells(i, myCol + 1).Value = newNum
i = i + 1
Next objFile
'Move over the newly copied files
Call MoveFilesAndFolders(Range(Cells(1, myCol), Cells(i - 1, myCol)))
'Clear links
Range(Cells(1, myCol), Cells(1, myCol + 1)).EntireColumn.Clear
End Sub
