Excel

Copying and Moving files of any type using Excel VBA

Ease of Use

Intermediate

Version tested with

XL2000,2003 

Submitted by:

XLGibbs

Description:

Two sample codes and a template file containing both codes which demonstrate how to apply use of the File System Object to quickly and easily copy, move, or rename files in a specified folder to within that folder, or within a specified destination folder. 

Discussion:

Many times, there is a need to move, backup,or copy multiple files. In some cases this may be a daily text file that is produced as part of daily download at your office that may be used in your Excel file (or elsewhere). There may be many of these, either in Excel, Word, .CSV, Text. In other cases, you may just have a need to regularly backup your work, or you have a need to move, copy or rename multiple files to another location (or rename it in it's existing location after it is saved). The files are not opened during this process. A destination folder will be created at the specified path if one did not previously exist. 

Code:

instructions for use

			

Option Explicit ''MUST set reference to Windows Script Host Object Model in the project using this code! Sub Copy_Files_To_New_Folder() ''This procedure will copy/move all files in a folder to another specified folder''' ''Can be easily modified Dim objFSO As FileSystemObject, objFolder As Folder, PathExists As Boolean Dim objFile As File, strSourceFolder As String, strDestFolder As String Dim x, Counter As Integer, Overwrite As String Application.ScreenUpdating = False 'turn screenupdating off Application.EnableEvents = False 'turn events off 'identify path names below: strSourceFolder = "C:\MyFolder" 'Source path strDestFolder = "C:\Backup" 'destination path, does not have to exist prior to execution ''''''''''NOTE: Path names can be strings built in code, cell references, or user form text box strings'''''' ''''''''''example: strSourceFolder = Range("A1") 'below will verify that the specified destination path exists, or it will create it: On Error Resume Next x = GetAttr(strDestFolder) And 0 If Err = 0 Then 'if there is no error, continue below PathExists = True 'if there is no error, set flag to TRUE Overwrite = MsgBox("The folder may contain duplicate files," & vbNewLine & _ "Do you wish to overwrite existing files with same name?", vbYesNo, "Alert!") 'message to alert that you may overwrite files of the same name since folder exists If Overwrite <> vbYes Then Exit Sub 'if the user clicks YES, then exit the routine.. Else: 'if path does NOT exist, do the next steps PathExists = False 'set flag at false If PathExists = False Then MkDir (strDestFolder) 'If path does not exist, make a new one End If 'end the conditional testing On Error GoTo ErrHandler Set objFSO = New FileSystemObject 'creates a new File System Object reference Set objFolder = objFSO.GetFolder(strSourceFolder) 'get the folder Counter = 0 'set the counter at zero for counting files copied If Not objFolder.Files.Count > 0 Then GoTo NoFiles 'if no files exist in source folder "Go To" the NoFiles section For Each objFile In objFolder.Files 'for every file in the folder... 'Below: If statements can be used to evaluate parts of file name for file type, 'or using the InStr method below, can identify parts of a file name to conditionally 'copy files based on any part of the file name. For non-extension checks, replace 'what is inside the " " to check for that within the file name. 'If InStr(1, objFile.Name, ".xls") Then ' Will copy only Excel files 'If InStr(1, objFile.Name, ".txt") Then ' Will copy only Text files objFile.Copy strDestFolder & "\" & objFile.Name 'use the destination path string, add a / separator and the file name 'objFile.Move strDestFolder & "\" & objFile.Name 'Syntax for MOVING file only, remove the ' to use Counter = Counter + 1 'increment a count of files copied 'End If 'where conditional check, if applicable would be placed. ' Uncomment the If...End If Conditional as needed Next objFile 'go to the next file MsgBox "All " & Counter & " Files from " & vbCrLf & vbCrLf & strSourceFolder & vbNewLine & vbNewLine & _ " copied/moved to: " & vbCrLf & vbCrLf & strDestFolder, , "Completed Transfer/Copy!" 'Message to user confirming completion Set objFile = Nothing: Set objFSO = Nothing: Set objFolder = Nothing 'clear the objects Exit Sub NoFiles: 'Message to alert if Source folder has no files in it to copy MsgBox "There Are no files or documents in : " & vbNewLine & vbNewLine & _ strSourceFolder & vbNewLine & vbNewLine & "Please verify the path!", , "Alert: No Files Found!" Set objFile = Nothing: Set objFSO = Nothing: Set objFolder = Nothing 'clear the objects Application.ScreenUpdating = True 'turn screenupdating back on Application.EnableEvents = True 'turn events back on Exit Sub 'exit sub here to avoid subsequent actions ErrHandler: 'A general error message MsgBox "Error: " & Err.Number & Err.Description & vbCrLf & vbCrLf & vbCrLf & _ "Please verify that all files in the folder are not currently open," & _ "and the source directory is available" Err.Clear 'clear the error Set objFile = Nothing: Set objFSO = Nothing: Set objFolder = Nothing 'clear the objects Application.ScreenUpdating = True 'turn screenupdating back on Application.EnableEvents = True 'turn events back on End Sub '''''''''''''''''''''''Rename and Copy Sample Code Below Sub Copy_and_Rename_To_New_Folder() ''MUST set reference to Windows Script Host Object Model in the project using this code! 'This procedure will copy all files in a folder, and insert the last modified date into the file name' 'it is identical to the other procedure with the exception of the renaming... 'In this example, the renaming has utilized the files Last Modified date to "tag" the copied file. 'This is very useful in quickly archiving and storing daily batch files that come through with the same name on 'a daily basis. Note: All files in current folder will be copied this way unless condition testing applied as in prior example. Dim objFSO As FileSystemObject, objFolder As Folder, PathExists As Boolean Dim objFile As File, strSourceFolder As String, strDestFolder As String Dim x, Counter As Integer, Overwrite As String, strNewFileName As String Dim strName As String, strMid As String, strExt As String Application.ScreenUpdating = False 'turn screenupdating off Application.EnableEvents = False 'turn events off 'identify path names below: strSourceFolder = "C:\MyFolder" 'Source path strDestFolder = "C:\Backup" 'destination path, does not have to exist prior to execution ''''''''''NOTE: Path names can be strings built in code, cell references, or user form text box strings'''''' ''''''''''example: strSourceFolder = Range("A1") 'below will verify that the specified destination path exists, or it will create it: On Error Resume Next x = GetAttr(strDestFolder) And 0 If Err = 0 Then 'if there is no error, continue below PathExists = True 'if there is no error, set flag to TRUE Overwrite = MsgBox("The folder may contain duplicate files," & vbNewLine & _ "Do you wish to overwrite existing files with same name?", vbYesNo, "Alert!") 'message to alert that you may overwrite files of the same name since folder exists If Overwrite <> vbYes Then Exit Sub 'if the user clicks YES, then exit the routine.. Else: 'if path does NOT exist, do the next steps PathExists = False 'set flag at false If PathExists = False Then MkDir (strDestFolder) 'If path does not exist, make a new one End If 'end the conditional testing On Error GoTo ErrHandler Set objFSO = New FileSystemObject 'creates a new File System Object reference Set objFolder = objFSO.GetFolder(strSourceFolder) 'get the folder Counter = 0 'set the counter at zero for counting files copied If Not objFolder.Files.Count > 0 Then GoTo NoFiles 'if no files exist in source folder "Go To" the NoFiles section For Each objFile In objFolder.Files 'for every file in the folder... 'parse the name in three pieces, file name middle and extension. In between, insert the 'last modified date. Other options may be a native Date function or a cell refernce to 'tag the renamed file in place of >=====Format(objFile.DateLastModified, "_mmm_dd_yy")===<<<< 'if strMid is not used, it can be removed or left as a null "" string strName = Left(objFile.Name, Len(objFile.Name) - 4) 'remove extension and leave name only 'strName = Range("A1") 'sample of renaming from cell A1, can by used for strMid as well strMid = Format(objFile.DateLastModified, "_mmm_dd_yy") 'insert and format files date modified into name 'strMid = Format(Now(),"_mmm_dd_yy") 'sample of formatting the current date into the file name strExt = Right(objFile.Name, 4) 'the original file extension strNewFileName = strName & strMid & strExt 'build the string file name (can be done below as well) objFile.Copy strDestFolder & "\" & strNewFileName 'copy the file with NEW name! 'objFile.Name = strNewFileName <====this can be used to JUST RENAME, and not copy 'The below line can be uncommented to MOVE the files AND rename between folders, without copying 'objFile.Move strDestFolder & "\" & strNewFileName 'End If 'where conditional check, if applicable would be placed. ' Uncomment the If...End If Conditional as needed Counter = Counter + 1 Next objFile 'go to the next file MsgBox "All " & Counter & " Files from " & vbCrLf & vbCrLf & strSourceFolder & vbNewLine & vbNewLine & _ " copied/moved to: " & vbCrLf & vbCrLf & strDestFolder, , "Completed Transfer/Copy!" 'Message to user confirming completion Set objFile = Nothing: Set objFSO = Nothing: Set objFolder = Nothing 'clear the objects Exit Sub NoFiles: 'Message to alert if Source folder has no files in it to copy MsgBox "There Are no files or documents in : " & vbNewLine & vbNewLine & _ strSourceFolder & vbNewLine & vbNewLine & "Please verify the path!", , "Alert: No Files Found!" Set objFile = Nothing: Set objFSO = Nothing: Set objFolder = Nothing 'clear the objects Application.ScreenUpdating = True 'turn screenupdating back on Application.EnableEvents = True 'turn events back on Exit Sub 'exit sub here to avoid subsequent actions ErrHandler: 'A general error message MsgBox "Error: " & Err.Number & Err.Description & vbCrLf & vbCrLf & vbCrLf & _ "Please verify that all files in the folder are not currently open," & _ "and the source directory is available" Err.Clear 'clear the error Set objFile = Nothing: Set objFSO = Nothing: Set objFolder = Nothing 'clear the objects Application.ScreenUpdating = True 'turn screenupdating back on Application.EnableEvents = True 'turn events back on End Sub

How to use:

  1. Open an Excel Workbook
  2. Select Tools/Macro/Visual Basic Editor (or Alt & F11)
  3. In the VBE Window, selection your file in the Project list
  4. Select Tools/Project Explorer/Insert/Module to add a standard code module
  5. Copy and Paste the code into the Module
  6. Enter the desired changes to the Source and Destination path (Directories)
  7. Save the Excel file, and Close if desired
  8. Also:The code is also contained as written in Module1 of the attached blank sample file
 

Test the code:

  1. In the VB Editor, designated a Source and Destination Folder
  2. Note: If the Destination folder does not exist, one will be created
  3. The Copy_All_Files_To_New_Folder code will work without any additional editing.
  4. The Copy_and_Rename_To_New_Folder code will work without any additional editing but will rename each file with the files "Last Modified Date"
  5. Sample alterations are included within the comments.
  6. To run the code from the VB Editor, press F5 or press the Green play button on the toolbar
  7. To run the code from the spreadsheet, Select Tools>Macro>{Select the macro}>Run, or press Alt & F8 to bring up the Macro menu>{Select the macro}>Run
  8. Upon completion, the files in the designated source folder will be copied/renamed into the specified destination directory.
 

Sample File:

CopyFileSample.zip 14.49KB 

Approved by mdmackillop


This entry has been viewed 671 times.

Please read our Legal Information and Privacy Policy
Copyright @2004 - 2020 VBA Express