Copying files to specific folder

Westbury

Board Regular
Joined
Jun 7, 2009
Messages
139
I've put the following code together to copy specific files from one folder to another based on a list contained in a spreradsheet. There are 2 problems which I'd appreaciatte some help with

1 the kill instuction doesn't work

and

2 the code is copying all of the files, not the ones identified in the list in the spreadsheet.

Thanks
Geoff


Sub copy_specific_files_in_folder()


Dim fso As Object
Dim sourcePath As String
Dim destinationPath As String
Dim xSPathStr As Variant, xDPathStr As Variant
Dim xRg As Range, xCell As Range
Dim fileExtn As String
Dim xVal As String
Dim ws As Worksheet


sourcePath = ThisWorkbook.Sheets("draft Intro").Range("B10")
destinationPath = ThisWorkbook.Sheets("draft Intro").Range("B22")
fileExtn = ".txt"


If Right(sourcePath, 1) <> "" Then
sourcePath = sourcePath & ""
End If


Set fso = CreateObject("scripting.filesystemobject")


If fso.folderexists(sourcePath) = False Then
MsgBox sourcePath & " does not exist"
Exit Sub
End If


If fso.folderexists(destinationPath) = False Then
MsgBox sourcePath & " does not exist"
Exit Sub
End If


'delete existing files


On Error Resume Next
Kill destinationPath & ".txt"
On Error GoTo 0


On Error Resume Next


Set xRg = Application.Worksheets("draft Intro").Range("H53:H4318")


For Each xCell In xRg
xVal = xCell.Value
If TypeName(xVal) = "String" And xVal <> "" Then
FileCopy sourcePath & xVal & fileExtn, destinationPath & xVal & fileExtn

End If
Next


'FSO.copyfile Source:=sourcePath & fileExtn, destination:=destinationPath
'MsgBox "files have been copied from " & sourcePath & vbCr & "to" & destinationPath


End Sub
 

Excel Facts

Get help while writing formula
Click the italics "fx" icon to the left of the formula bar to open the Functions Arguments dialog. Help is displayed for each argument.
Try these changes (untested etc.)
Code:
If Right(destinationPath , 1) <> "\" Then destinationPath = destinationPath & "\"
Code:
'delete existing files
fso.DeleteFile(destinationPath & "*.txt"), True
The rest of it looks correct, though I would remove the On Error Resume Next to see if any errors occur.
 
Upvote 0
Code:
Sub copy_specific_files_in_folder()
    
    Dim strSrc    As String
    Dim strDest   As String
    Dim strFile   As String
    Dim vRg       As Variant
    Dim vVal      As Variant
    Dim counter   As Long
    Const strExt  As String = ".txt"
    
    With ThisWorkbook.Sheets("draft Intro")
        
        'Source path
        strSrc = .Range("B10")
        If strSrc = Empty Then
            MsgBox "No 'Source' path listed in cell B10", vbExclamation, "Invalid Entry"
            Application.Goto .Range("B10")
            Exit Sub
        End If
        If Dir(strSrc, vbDirectory) = "" Then
            MsgBox strSrc, vbExclamation, "Source Folder Does Not Exist"
            Application.Goto .Range("B10")
            Exit Sub
        End If
        If Right(strSrc, 1) <> "\" Then strSrc = strSrc & "\"
        
        'Destination path
        strDest = .Range("B22")
        If strDest = Empty Then
            MsgBox "No 'Destination' path listed in cell B22", vbExclamation, "Invalid Entry"
            Application.Goto .Range("B22")
            Exit Sub
        End If
        If Dir(strDest, vbDirectory) = "" Then
            MsgBox strDest, vbExclamation, "Destination Folder Does Not Exist"
            Application.Goto .Range("B22")
            Exit Sub
        End If
        If Right(strDest, 1) <> "\" Then strDest = strDest & "\"
        
        'delete existing files in destination folder
        strFile = Dir(strDest & "*" & strExt)
        Do While strFile <> ""
            Kill strDest & strFile
            strFile = Dir
        Loop
        
        'Copy file list
        vRg = .Range("H53:H4318").Value
        For Each vVal In vRg
            If vVal <> Empty Then
                If Dir(strSrc & vVal & strExt) <> "" Then 'if file exists
                    FileCopy strSrc & vVal & strExt, strDest & vVal & strExt
                    counter = counter + 1
                End If
            End If
        Next
    
    End With
    
    MsgBox "From: " & vbCr & strSrc & vbCr & vbCr & _
           "To:" & vbCr & strDest, vbInformation, _
           counter & " files have been copied."
    
End Sub
 
Last edited:
Upvote 0

Forum statistics

Threads
1,213,558
Messages
6,114,297
Members
448,564
Latest member
ED38

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top