Copyfile permission refusée

Bonjour,

J'ai créé un code vba qui me permet de copier des fichiers jpg sur un disque dur externe.
Il me copie uniquement les fichiers selon la date de creation que j'ai choisi
J'ai également un code vba qui me détecte la lettre par exemple F:\ du disque dur Externe car parfois cette lettre change.

Par contre à chaque fois que je lance mon bout de code vba il y a souvent une erreur (70) permission refusée qui m'empêche de copier les fichiers.
Peu être est ce le fait que le dossier de destination du disque dur externe est en lecture seule?
J'ai déjà désactivé manuellement la lecture seule de ce dossier mais ça se réactive tout seul:

Je vous donnes mon code vba complet car on ne sait jamais que cette Erreur (70) soit du à un bout de code manquant ou mal écrit.

Merci d'avance pour votre aide

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("entrez la date de renommage des tags." & vbCrLf & "Exemple: 27/11/2014", "entrez la date", (Date))
If testdate = "" Then Exit Sub
If Not IsDate(testdate) Then
MsgBox "La date entrée n'est pas valide." & vbCrLf _
& "Veuillez re-saisir la date."
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 = "OUI"
Exit For
End If
End If
Next
End With
If Sheets("macros").Range("a203").Value = "" Then
MsgBox "Le disque externe de sauvegarde n'est pas connecté en 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
End If

Next oFolderItem

If a = "" Then
MsgBox "Il n'y a aucun tag pour cette date sélectionnée le: " & testdate & vbCrLf _
& "Veuillez choisir une autre date", vbCritical
Exit Sub
Else
MsgBox "Il y a eu: " & a & " tags qui ont été renommés le: " & testdate & vbCrLf & _
" sans les doublons et sans les tags qui n'ont pas été renommés."
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 "Il y a eu: " & b & " tags qui ont été corrigés: " & vbCrLf & _
" et qui ont été sauvegardés sur le disque externe."
End If

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