Copying files to specific folder

[Westbury]

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

 

[John_w]

Try these changes (untested etc.)

If Right(destinationPath , 1) <> "\" Then destinationPath = destinationPath & "\"

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

 

[AlphaFrog]

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

 

[Westbury]

John_w & AlphaFrog,

Thank you for these useful solutions. Both work.

Geoff