Permiso de copia de archivo denegado

Hola,

He creado un código VBA que me permite copiar archivos jpg en un disco duro externo.
Solo copia los archivos según la fecha de creación que he elegido.
También tengo un código VBA que me detecta la letra, por ejemplo F:\, del disco duro externo porque a veces esta letra cambia.

Sin embargo, cada vez que ejecuto mi código VBA, a menudo aparece un error (70) de permiso denegado que me impide copiar los archivos.
Tal vez sea porque la carpeta de destino del disco duro externo está en solo lectura.
Ya desactivé manualmente la solo lectura de esta carpeta, pero se reactiva por sí sola:

Te doy mi código VBA completo porque no se sabe si este error (70) se debe a un fragmento de código que falta o está mal escrito.

Gracias de antemano por tu ayuda

Sheets("cp87").Select
Sheets("macros").Range("a203").Value = ""
Dim appShell As Object
Dim FileName As Variant
Dim FilePath As Variant
Dim oFolder As Object
Dim oFolderItem As Object
Dim testdate As Variant

FolderPath = "D:\Users\Public\IMPORT\TAGSIMPORTAFAIRE\"
FileName = "*.jpg"

EnterDate:
testdate = InputBox("introduce la fecha del renombrado de las etiquetas." & vbCrLf & "Ejemplo: 27/11/2014", "introduce la fecha", (Date))
If testdate = "" Then Exit Sub
If Not IsDate(testdate) Then
MsgBox "La fecha introducida no es válida." & vbCrLf _
& "Por favor, vuelve a introducir la fecha."
GoTo EnterDate
End If
testdate = CDate(testdate)

Set appShell = CreateObject("Shell.Application")
Set oFolder = appShell.Namespace(FolderPath)

For Each oFolderItem In oFolder.Items
If oFolderItem.Name Like FileName Then

If DateValue(oFolder.GetDetailsOf(oFolderItem, 3)) = testdate Then

If Not oFolderItem.Name Like "*TAGSAFAIRE*" Then
a = a + 1
Dim destination As String
Dim objDrive As Object
With CreateObject("Scripting.FileSystemObject")
For Each objDrive In .Drives
If objDrive.IsReady Then
If objDrive.VolumeName = "VERBATIM HD" Then
destination = objDrive.Path & "\SAUVEGARDE IMPORT\"
Sheets("macros").Range("a203").Value = "SÍ"
Exit For
End If
End If
Next
End With
If Sheets("macros").Range("a203").Value = "" Then
MsgBox "¡El disco duro externo de respaldo no está conectado por USB!", vbCritical
Exit Sub
End If

Dim xlobj As Object
Set xlobj = CreateObject("Scripting.FileSystemObject")
xlobj.CopyFile FolderPath & oFolderItem.Name, destination & oFolderItem.Name, True

Set xlobj = Nothing

End If

End If

Next oFolderItem

If a = "" Then
MsgBox "No hay ninguna etiqueta para la fecha seleccionada el: " & testdate & vbCrLf _
& "Por favor, elige otra fecha", vbCritical
Exit Sub
Else
MsgBox "Se han: " & a & " etiquetas que han sido renombradas el: " & testdate & vbCrLf & _
" sin duplicados y sin las etiquetas que no han sido renombradas."
End If

Dim appShell2 As Object, oFolder2 As Object, oFolderItem2 As Object

FolderPath = "D:\Users\Public\IMPORT\TAGSIMPORTAFAIRE\"
Set appShell2 = CreateObject("Shell.Application")
Set oFolder2 = appShell2.Namespace(FolderPath)

Dim rng As Range, cellul As Range
Set rng = Sheets("archivage").Range("z2:z65000")
For Each cellul In rng
If cellul.Value <> "" Then
On Error GoTo suit
b = b + 1
Dim xlobj2 As Object
Set xlobj2 = CreateObject("Scripting.FileSystemObject")
SetAttr FolderPath & cellul.Value, vbNormal
xlobj2.CopyFile FolderPath & cellul.Value, destination & cellul.Value, True

Set xlobj2 = Nothing
End If
suit::

Next cellul

If b = "" Then
Else
MsgBox "Se han: " & b & " etiquetas que han sido corregidas: " & vbCrLf & _
" y que han sido guardadas en el disco externo."
End If

Sheets("archivage").Range("z2:z65000") = ""
Exit Sub