Sub Déplacement()
Dim FS As New Scripting.FileSystemObject, TDon(), L As Long
TDon = Intersect(ActiveSheet.[B2:G1000000], ActiveSheet.UsedRange).Value
On Error Resume Next
For L = 1 To UBound(TDon, 1)
If TDon(L, 6) = "OK" Then
Err.Clear: FS.CopyFolder TDon(L, 1), TDon(L, 2)
If Err = 0 Then FS.DeleteFolder TDon(L, 1)
End If
Next L
End Sub