Unfortunately life brings about its fair share of admin tasks. We can cry or we can automate them in an interesting way which stops us from gouging our eyes out. One of those, intrinsic to having data in a file-system, is copying lots of different files to one folder or a mix of different folders: perhaps you have a list of shape-files and their accompanying dbfs and you want to move all of them into one giant folder, or perhaps you want to replicate the existing folder structure but skip some folder in the middle, or you have just identified some tags for your files and you want to move them into folders (called by the respective tags).

As far as I am aware robocopy does not have such functionality. The first thought was to write a simple Python script; however what would the input be – a CSV giving file-name, from, to … an Excel file? So I decided to just stick with the CSV and write a VBA script.

My method is as follows and the VBA code is at the bottom:

  1. Clean-up and the cells containing the path
  2. If one of the paths is longer than 260 characters then break
  3. Verify the cells are non-empty
  4. Verify the source-file exists
  5. Calculate the SHA1 checksum for the source-file
  6. Create the directory structure for the destination
  7. Copy using FileSystemObject
  8. Verify the copied file exists and then if so: verify the checksums match
  9. If everything goes well then display “Copied Successfully!” along with the checksum for reference, otherwise make a note of the error

I believe the most important component is accurate logging and so even if a file is not copied correctly, as long as that is logged (e.g. the checksums do not match) then the 0.001% problematic files can be manually investigated.

Usage:

Sheet “VBA Copy Delete Macros” – This sheet accepts a list of files along with the desired destination path, creates the required sub-folder structure and then copies the file into the new location robustly (note: that files do not have to be closed to be copied across – they can be open – and any possible errors/issues are logged in the spreadsheet to analyse). Then the original files can be deleted from the original location if required

Required Inputs for Copy

– Col A: Name of file including extension (“File-Namee.g. Dec15.doc”)

– Col B: Current location of file excluding the file-name (“File Source” e.g. C:\M\SALES\Contracts“)

– Col C: Desired copy-location of file excluding the file-name (“(File Destination)” e.g.C:\extracted\SALES\Contracts“)

Required Inputs for Delete

– Col A: Name of file including extension (“File-Name” e.g. Dec15.doc”)

– Col B: Current location of file excluding the file-name (“File Source” e.g. C:\M\SALES\Contracts“)

Output:

– Col D: Status of transfer/delete  (“Status” e.g. Copied Successfully! )

The list of all possible values:

“Copied Successfully!” – SUCCESS

“Path too long for VBA FileSystemObject” – ERROR (NOT COPIED)

“Source/Destination Cells Empty” – ERROR (NOT COPIED)

“File Does Not Exist” – ERROR (NOT COPIED)

“Not Copied – No Permission” – ERROR (NOT COPIED)

“Not Copied – Error (error_number)” – ERROR (NOT COPIED)

“Copied – Checksum Error” – ERROR (COPIED INCORRECTLY)

– Col E: Calculated checksum to verify file has been copied across properly (“CheckSum” e.g. SHA1: 96f8b5832ec9359bdbbac4fabf91de848d4a64b2″)

An example screenshot is below:

excel_copy_paste

Option Explicit

Sub CopyFiles()
'Copy files from old location to new location
'Potentially: Shell "cmd /c robocopy " & Source & " " & Destination & " " & File
'File Name | From Location | To Location | Status
Dim fs As Object
Dim SourcePath, DestPath As String
Dim cell As Range
Dim counting As Long
Dim target As Long
Dim header As Long
Dim message As Variant
Dim SHA1_pre As String
Dim SHA1_post As String

header = 9
target = LastRow(ActiveSheet)
message = MsgBox("Will copy " & (target - header) & " files from source to destination.", vbYesNo, "Copy Files")
If message <> vbYes Then Exit Sub

Application.DisplayStatusBar = True
Application.StatusBar = ""

Set fs = CreateObject("Scripting.FileSystemObject")

For Each cell In Range("A10:A" & target)
    Application.StatusBar = "Processing: " & (cell.Row - header) & "/" & (target - header)
    If (cell <> vbNullString) Then
        'Some house-keeping
        cell = Trim(cell)
        cell.Offset(, 1) = Trim(cell.Offset(, 1))
        cell.Offset(, 2) = Trim(cell.Offset(, 2))
        cell.Offset(, 3) = vbNullString
        cell.Offset(, 4) = vbNullString

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

        If Right(cell.Offset(, 1), 1) = "\" Then
            cell.Offset(, 1) = Left(cell.Offset(, 1), Len(cell.Offset(, 1)) - 1)
        End If

        If Right(cell.Offset(, 2), 1) = "\" Then
            cell.Offset(, 2) = Left(cell.Offset(, 2), Len(cell.Offset(, 2)) - 1)
        End If

        'Run
        SourcePath = cell.Offset(, 1) & "\" & cell
        DestPath = cell.Offset(, 2) & "\" & cell

        If Len(SourcePath) > 260 Or Len(DestPath) > 260 Then
        cell.Offset(, 3) = "Path too long for VBA FileSystemObject"
            GoTo skipcode:
        End If

        If (cell.Offset(, 1) = vbNullString Or cell.Offset(, 2) = vbNullString) Then
        cell.Offset(, 3) = "Source/Destination Cells Empty"
            GoTo skipcode:
        End If

        'Test source-file exists
        If Not FileExists(SourcePath) Then
            cell.Offset(, 3) = "File Does Not Exist"
            GoTo skipcode:
        End If

        'Checksum verification (pre)
        SHA1_pre = FileToSHA1Hex(SourcePath)

        'Create destination(sub)-folder if doesn't already exist
        If Not FolderExists(cell.Offset(, 2)) Then
        'If Len(Dir(cell.Offset(, 2), vbDirectory)) = 0 Then
            Call MakeDirectory(cell.Offset(, 2) & "\")
        End If

        'Copy file from source to destination
        On Error Resume Next

            'COPY
            fs.Copyfile SourcePath, DestPath

            'Test destination-file created correctly
            If Not FileExists(DestPath) Then
                If Err.Number = 70 Then
                    cell.Offset(, 3) = "Not Copied - No Permission"
                Else
                    cell.Offset(, 3) = "Not Copied - Error " & CStr(Err.Number)
                End If
            Else
                'Check-sum verification
                SHA1_post = FileToSHA1Hex(DestPath)

                If SHA1_pre = SHA1_post Then
                    cell.Offset(, 3) = "Copied Successfully!"
                    cell.Offset(, 4) = "SHA1: " & SHA1_post
                    counting = counting + 1
                Else
                    cell.Offset(, 3) = "Copied - Checksum Error"
                    cell.Offset(, 4) = "SHA1 Source: " & SHA1_pre & Chr(13) & "SHA1 Destination: " & SHA1_post
                End If
            End If
        On Error GoTo 0
    End If
skipcode:
Next cell

MsgBox ("Done! Copied: " & counting & "/" & (target - header) & " successfully.")
Set fs = Nothing
Application.StatusBar = ""
Application.DisplayStatusBar = False
End Sub

Sub DeleteFiles()
'Delete files included in list
'File Name | From Location | Status
Dim fs As Object
Dim SourcePath, DestPath As String
Dim cell As Range
Set fs = CreateObject("Scripting.FileSystemObject")
Dim counting As Long
Dim target As Long
Dim header As Long
Dim message As Variant

header = 9
target = LastRow(ActiveSheet)
message = MsgBox("Will delete " & (target - header) & " files from source.", vbYesNo, "Delete Files")
If message <> vbYes Then Exit Sub

Application.DisplayStatusBar = True
Application.StatusBar = ""

For Each cell In Range("A10:A" & target)
    Application.StatusBar = "Processing: " & (cell.Row - header) & "/" & (target - header)
    If (cell <> vbNullString) Then
        'Some house-keeping
        cell = Trim(cell)
        cell.Offset(, 1) = Trim(cell.Offset(, 1))

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

        If Right(cell.Offset(, 1), 1) = "\" Then
            cell.Offset(, 1) = Left(cell.Offset(, 1), Len(cell.Offset(, 1)) - 1)
        End If

        'Run
        SourcePath = cell.Offset(, 1) & "\" & cell

        If Len(SourcePath) > 260 Or Len(DestPath) > 260 Then
        cell.Offset(, 3) = "Path too long for VBA FileSystemObject"
            GoTo skipcode:
        End If

        If (cell.Offset(, 1) = vbNullString) Then
        cell.Offset(, 3) = "Source/Destination Cells Empty"
            GoTo skipcode:
        End If

        'Test source-file exists
        If Not FileExists(SourcePath) Then
            cell.Offset(, 3) = "File Does Not Exist"
            GoTo skipcode:
        End If

        'Delete
    On Error Resume Next
            fs.deletefile SourcePath

        'Test file deleted
        If FileExists(SourcePath) Then
            Debug.Print Err.Number
            If Err.Number = 70 Then
                cell.Offset(, 3) = "Not Deleted - No Permission"
            Else
                cell.Offset(, 3) = "Not Deleted - " & CStr(Err.Number)
            End If
        Else
            cell.Offset(, 3) = "Deleted Successfully!"
            counting = counting + 1
        End If
    On Error GoTo 0
    End If
skipcode:
Next cell

MsgBox ("Done! Deleted: " & counting & "/" & (target - header) & " successfully.")
Set fs = Nothing
Application.StatusBar = ""
Application.DisplayStatusBar = False
End Sub

'''''''''''''''''''''
'Referenced functions
'''''''''''''''''''''

Function LastRow(sh As Worksheet)
On Error Resume Next
    LastRow = sh.Cells.Find(What:="*", _
                                After:=sh.Range("A1"), _
                                Lookat:=xlPart, _
                                LookIn:=xlFormulas, _
                                SearchOrder:=xlByRows, _
                                SearchDirection:=xlPrevious, _
                                MatchCase:=False).Row
On Error GoTo 0
End Function

Function GetName(ByVal longname As String)
'Get file-name from path
Dim splitname As Variant
Dim i As Long
splitname = Split(longname, "\")
Do While GetName = vbNullString
    If i <= UBound(splitname) Then
        GetName = splitname(UBound(splitname) - i)
        i = i + 1
    End If
Loop
End Function

Public Sub MakeDirectory(FolderPath As String)
'Make sub-directories
Dim x, i As Integer, strPath As String
x = Split(FolderPath, "\")

For i = 0 To UBound(x) - 1
    strPath = strPath & x(i) & "\"
    If Not FolderExists(strPath) Then MkDir strPath
Next i
End Sub

Function FileExists(ByVal FileToTest As String) As Boolean
'Check if file exists
On Error Resume Next
   FileExists = (Dir(FileToTest) <> "")
On Error GoTo 0
End Function

Function FolderExists(FolderPath As String) As Boolean
'Check if folder exists
On Error Resume Next
    ChDir FolderPath
If Err Then FolderExists = False Else FolderExists = True
End Function

Function GetFileBytes(ByVal path As String) As Byte()
'Get File Length
Dim lngFileNum As Long
Dim bytRtnVal() As Byte
'Allocate next unused number (rather than Filenum 1)
lngFileNum = FreeFile

Open path For Binary Access Read As lngFileNum
    ReDim bytRtnVal(LOF(lngFileNum) - 1&) As Byte
    Get lngFileNum, , bytRtnVal
Close lngFileNum

GetFileBytes = bytRtnVal
Erase bytRtnVal

End Function

Function FileToSHA1Hex(ByVal sFileName As String) As String
'SHA256 checksum
Dim enc As Object
Dim bytes As Variant
Dim outstr As String
Dim pos As Integer
Set enc = CreateObject("System.Security.Cryptography.SHA1CryptoServiceProvider")

bytes = GetFileBytes(sFileName)
bytes = enc.ComputeHash_2((bytes))

For pos = 1 To LenB(bytes)
    outstr = outstr & LCase(Right("0" & Hex(AscB(MidB(bytes, pos, 1))), 2))
Next

FileToSHA1Hex = outstr
Set enc = Nothing
End Function

Sheet “VBA Directory Macros” – This sheet recursively lists all files in a chosen directory (showing just the list in the first column as-well as the structure/hierarchy in the proceeding columns)

Just a bit of fun really but I thought it could be interesting to use together with the above to verify everything worked (or before; to get a list of files for the input)

recursive_list

Sub DirectoryTree()
'Code to list all files in a directory recursively & produce tree structure diagram
'Using short-path to avoid issues with paths longer than 260
Dim myPath As String
Dim myFile As String
Dim myExtension As String
Dim FldrPicker As FileDialog
Dim r, c, lstrow As Long
Dim filecount As Long
Dim arrFiles As Variant
Dim file As Variant
Dim FSO As Object
Dim objFolder As Object
Dim count As Long

'Retrieve Target Folder Path From User
Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)
With FldrPicker
    .Title = "Select A Target Folder for Destination"
    .AllowMultiSelect = False
    If .Show <> -1 Then GoTo nextcode
    myPath = .SelectedItems(1) & "\"
End With
'In Case of Cancel
nextcode:
myPath = myPath
If myPath = "" Then Exit Sub

Application.ScreenUpdating = False
r = 1
c = 2
Set FSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = FSO.GetFolder(myPath)
'Set to shortpath
Set objFolder = FSO.GetFolder(objFolder.ShortPath)
Set arrFiles = objFolder.Files
'Print Initial Directory
Cells(r, c).Value = GetName(objFolder.path)
Cells(r, c).Font.Bold = True
c = c + 1

filecount = 0
For Each file In arrFiles
    r = r + 1
    filecount = filecount + 1
    'Diagram
    Cells(r, c).Value = file.Name
    'Full Path
    Cells(r, 1).Value = file.path
    Cells(r, 2).Value = " "
Next

'Robustness
If filecount < objFolder.Files.count Then
    For count = 1 To (objFolder.Files.count - filecount)
        r = r + 1
        Cells(r, 1).Value = "File-name not retrieved: " & objFolder.path
    Next count
End If

'Recursively Print Sub-Directories
lstrow = r
ShowSubFolders objFolder, r, c, lstrow
'Format
Application.PrintCommunication = False
With ActiveSheet.PageSetup
        .Orientation = xlLandscape
        .FitToPagesWide = 1
        .FitToPagesTall = False
End With
Application.PrintCommunication = True
Application.ScreenUpdating = True
End Sub

Sub ShowSubFolders(ByVal objFolder As Object, ByVal r As Long, ByVal c As Long, Optional ByRef lstrow As Long)
'Recursively go through sub-folders
Dim arrFiles As Variant
Dim file As Variant
Dim FSO As Object
Dim colFolders As Object
Dim objsubfolder As Object
Dim filecount As Long
Dim count As Long

'Set to shortpath
Set FSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = FSO.GetFolder(objFolder.ShortPath)
Set colFolders = objFolder.SubFolders
On Error Resume Next
'For Permission Denied errors (e.g. recycle bin)
'Better error-handling?
For Each objsubfolder In colFolders
    r = lstrow + 1
    Cells(r, c).Value = GetName(objsubfolder.path)
    Cells(r, c).Font.Bold = True
    Set arrFiles = objsubfolder.Files
    c = c + 1

        filecount = 0
        For Each file In arrFiles
            'Diagram
            r = r + 1
            filecount = filecount + 1
            Cells(r, c).Value = file.Name
            'Full Path
            Cells(r, 1).Value = file.path
            Cells(r, 2).Value = " "
        Next

        'Robustness
        If filecount < objsubfolder.Files.count Then
            For count = 1 To (objsubfolder.Files.count - filecount)
                r = r + 1
                Cells(r, 1).Value = "File-name not retrieved: " & objsubfolder.path
            Next count
        End If

    lstrow = r
    ShowSubFolders objsubfolder, r, c, lstrow
    c = c - 1
Next
On Error GoTo 0
End Sub