From Hyperlink save all attachments in one folder

Abhijeet · Jun 18, 2015

Hi

In A1:A100 hyperlink data i want save all attachments from each hyperlink in one folder please tell me how to do this.

Luke M · Jun 18, 2015

Since you've once again posted a question with very little information, here is a list of questions that need answered:

Where are the files currently?
What is in cells A1:A100? (Full file path, or just the name, or something else entirely)
Where are we moving the files?
You mention attachments, but do you mean files?
Are we moving the linked files, or making copies?
If you move a linked file, hyperlink won't work. Is this ok?
If we make a copy of linked file, should we update hyerplink?

Abhijeet · Jun 18, 2015

Hi Luke M

Sorry I am not Mention such Info in my post A1:A100 in this range each cell has Hyperlink that is full path where is that files save or Folder

I want to copy paste all attachments files in particular folder on my desktop or In Shared Drive any folder that path we can mention in macro

Hyper link Attachments files as well as folder but in that folder also some type of files. so i want all files need to copy paste not cut paste so hyper link can work

Problem is now i am doing manually work but i want to save time so i want ur help pls tell me how to do this

Luke M · Jun 18, 2015

Adjust destPath and myRange as needed, then run the first macro.

Code:

Sub MoveFilesAndFolders()
Dim c As Range
Dim destPath As String
Dim sourcePath As String
Dim fName As String
Dim myRange As Range

'CHANGE THESE LINES
'===============
'Where are we moving everything to?
destPath = "C:\My Documents"
'Which cells have hyperlinks?
Set myRange = Range("A1:A100")
'===============

'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 Copy_Folder(sourcePath, destPath)
    Else
        'It's a file
        FileCopy sourcePath, destPath & fName
    End If
nextCell:
Next c
MsgBox "Files and folders copied to:" & vbNewLine & destPath
End Sub


Private Sub Copy_Folder(FromPath As String, ToPath As String)
'Macro obtained from:
'http://www.rondebruin.nl/win/s3/win026.htm

'This example copy all files and subfolders from FromPath to ToPath.
'Note: If ToPath already exist it will overwrite existing files in this folder
'if ToPath not exist it will be made for you.
    Dim FSO As Object

    'If you want to create a backup of your folder every time you run this macro
    'you can create a unique folder with a Date/Time stamp.
    'ToPath = "C:\Users\Ron\" & Format(Now, "yyyy-mm-dd h-mm-ss")

    If Right(FromPath, 1) = "\" Then
        FromPath = Left(FromPath, Len(FromPath) - 1)
    End If

    If Right(ToPath, 1) = "\" Then
        ToPath = Left(ToPath, Len(ToPath) - 1)
    End If

    Set FSO = CreateObject("scripting.filesystemobject")

    If FSO.FolderExists(FromPath) = False Then
        MsgBox FromPath & " doesn't exist"
        Exit Sub
    End If

    FSO.CopyFolder Source:=FromPath, Destination:=ToPath
    'MsgBox "You can find the files and subfolders from " & FromPath & " in " & ToPath

End Sub

Abhijeet · Jun 19, 2015

Hi Luke M

Your Solution Is Perfect & nice work Thanks for your help

Please tell me if In Range A1:A100 i want dynamic range means some time data is very less some times more then what shall i do in that case can i use Do while loop if next cell is blank then macro can stop not go to next cells i can try if unable to do this then pls help me in that time but Still what ever ur solution is very good now my turn to do something

Luke M · Jun 19, 2015

Thanks for the feedback, Abhijeet, and you're welcome.

Abhijeet · Jun 23, 2015

Hi Luke M

Can u please tell me in this macro can get Info about from which hyperlink what are the files name which was save in the folder.Details can save in next sheet of same workbook and particular hyperlink wise how many files are saved in the folder that counts i want Is it possible to do this please tell me

Abhijeet · Jun 28, 2015

Hi Luke M

This Macro Same file name then overwrite the file its problem for me Now i need ur help in Column B cell Number i mention then That hyperlink all files Rename the file first that Number then what ever namee of that file i want so pls tell me how to do this

Luke M · Jun 29, 2015

I'm afraid I don't understand what you said.

Abhijeet · Jun 29, 2015

Luke M

Same File Name If then Macro Overwrite that File

Then Now I am putting Codes in Colume B Codes means Numbers

If u look attach file If File name from A1 Hyper link is this(Delete Files.xlsm)

Then B1 cell has 93 Number so i want (93 Delete Files.xlsm) this File Name Save In Folder

B2 cell Has 105 Number So i want (105 then that File Name)

Luke M · Jun 29, 2015

This might work. Folders are handled differently, since they get copied over in a single shot, but I turned on the option to timestamp the folder, so nothing gets overwritten that way. If the hyperlink is to a file, the number gets places before the file name.

Code:

Sub MoveFilesAndFolders()
Dim c As Range
Dim destPath As String
Dim sourcePath As String
Dim fName As String
Dim myRange As Range

'CHANGE THESE LINES
'===============
'Where are we moving everything to?
destPath = "C:\Users\swami\Desktop\Dest Files Move"
'Which cells have hyperlinks?
Set myRange = Range("A1:A100")
'===============

'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 Copy_Folder(sourcePath, destPath)
    Else
        'It's a file
       FileCopy sourcePath, destPath & c.Offset(, 1).Value & " " & fName
    End If
nextCell:
Next c
MsgBox "Files and folders copied to:" & vbNewLine & destPath
End Sub

Private Sub Copy_Folder(FromPath As String, ToPath As String)
'Macro obtained from:
'http://www.rondebruin.nl/win/s3/win026.htm

'This example copy all files and subfolders from FromPath to ToPath.
'Note: If ToPath already exist it will overwrite existing files in this folder
'if ToPath not exist it will be made for you.
   Dim FSO As Object

    'If you want to create a backup of your folder every time you run this macro
   'you can create a unique folder with a Date/Time stamp.
   ToPath = "C:\Users\Ron\" & Format(Now, "yyyy-mm-dd h-mm-ss")

    If Right(FromPath, 1) = "\" Then
        FromPath = Left(FromPath, Len(FromPath) - 1)
    End If

    If Right(ToPath, 1) = "\" Then
        ToPath = Left(ToPath, Len(ToPath) - 1)
    End If

    Set FSO = CreateObject("scripting.filesystemobject")

    If FSO.FolderExists(FromPath) = False Then
        MsgBox FromPath & " doesn't exist"
        Exit Sub
    End If

    FSO.CopyFolder Source:=FromPath, Destination:=ToPath
    'MsgBox "You can find the files and subfolders from " & FromPath & " in " & ToPath

End Sub

Abhijeet · Jun 29, 2015

Hi Luke M

If Hyper Link contains file then macro works Perfect but If Hyperlink Contains Folder then Its Not Wok means File Not Rename In Destination Folder Only Backup Folder Create Please tell me For this problem

Abhijeet · Jun 29, 2015

Luke M

If Hyperlink Folder then macro Create Backup Folder but i want Same Files Rename with the Number can u pls tell me what change need to do for this changes

Luke M · Jun 29, 2015

Can't be done, due to my earlier statement

Folders are handled differently, since they get copied over in a single shot

With a hyperlinked folder, we don't look at each individual file in the folder (and subfolders), so there's no chance to rename them.

Abhijeet · Jun 30, 2015

Luke M

Can we Convert that Folders files into Hyperlink i can try to do this if i am unable to do this then please help me

Abhijeet · Jun 30, 2015

Luke M
I Have this Macro but this not work in our Macro Because this macro create Formula of Hyperlink. Can we do If Hyperlink Folder Then Macro Create Temp File then Create Hyperlink of those files & Rename those files.No need to save that temp file is this possible please tell me

Code:

Sub CreateHyperlinks()
'Creates a Table of Contents (ToC) in active sheet of PDFs in specified folder
Dim myFolder As String
Dim fName As String
Dim myArry As Variant
Dim fPath As String
Dim recCount As Long

Sheet1.Columns("A:A").Clear

'Where are the files located?
If Application.FileDialog(msoFileDialogFolderPicker).Show = flase Then
Exit Sub
Else
myFolder = Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1)
End If


'Make sure that final slash mark was added
If Right(myFolder, 1) <> "\" Then
    myFolder = myFolder & "\"
    Range("IV2").Value = myFolder
End If
  
fPath = Dir(myFolder)


'Create ToC on active sheet, starting in row 1
recCount = 0
Application.ScreenUpdating = False

'Loop through all the files, building Hyperlink formulas
Do Until fPath = ""
    recCount = recCount + 1
    Cells(recCount, "A").Formula = "=HYPERLINK(""" & myFolder & fPath & """,""" & fPath & """)"
    fPath = Dir()
Loop
Application.ScreenUpdating = True

'Brief message to user
MsgBox "Number of files found: " & recCount, vbOKOnly, "Files found"
End Sub

Abhijeet · Jun 30, 2015

Hi Luke M

This Works Perfect please tell me how to put in Our Macro this coding and rename the files

Code:

Sub Example1()
Dim objFSO As Object
Dim objFolder As Object
Dim objFile As Object
Dim i As Integer

'Create an instance of the FileSystemObject
Set objFSO = CreateObject("Scripting.FileSystemObject")
'Get the folder object
Set objFolder = objFSO.GetFolder("C:\Users\swami\Desktop\PDF")
i = 1
'loops through each file in the directory
For Each objFile In objFolder.Files
    'select cell
    Range(Cells(i + 1, 1), Cells(i + 1, 1)).Select
    'create hyperlink in selected cell
    ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:= _
        objFile.Path, _
        TextToDisplay:=objFile.Name
    i = i + 1
Next objFile
End Sub

Luke M · Jun 30, 2015

Clear out previous macros, run new MainMacro. This works by temporarily storing hyperlinks in an unused column (currently set to use col Z).

Code:

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:A100"))
'===============

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
    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

Abhijeet · Jun 30, 2015

Luke M

Thanks For ur Support For this Its Work Perfect.Only one thing is I can Tried to solve that if any need ur help then i will tell u pls help me. Thanks again for ur Time & Support

Abhijeet · Jul 1, 2015

Luke M

Thanks Luke M All work Perfect on my Live Data.

Abhijeet · Mar 17, 2017

Hi

From this macro now one challenge i am facing thumbs.db file identify by macro so macro not work because this file unable to move or delete so please tell me how to move only particular extension files or how to skip this file

From Hyperlink save all attachments in one folder

Active Member

Excel Ninja

Active Member

Excel Ninja

Active Member

Excel Ninja

Active Member

Active Member

Excel Ninja

Active Member

Attachments

Excel Ninja

Active Member

Active Member

Excel Ninja

Active Member

Active Member

Active Member

Excel Ninja

Active Member

Active Member

Active Member