Macro pour déplacer l'ensemble des répertoires d'un Dossier avec leurs fichiers?

Dim Liste() as String
Dim a As Integer
Dim x As Integer
a = 0
x = 1
MyPath = "C:\MonDossier\"
MyName = Dir(MyPath, vbDirectory)
Do While MyName <> ""
             ' Ignore le répertoire courant et le répertoire contenant le 
répertoire courant
    If MyName <> "." And MyName <> ".." Then
            ' Utilise une comparaison au niveau du bit pour vérifier que 
MyName est un répertoire.
        If (GetAttr(MyPath & MyName) And vbDirectory) = vbDirectory Then
            ReDim Preserve Liste(a)
            Liste(a) = MyName
            Range("A" & x).Value = MyName 'je liste les répertoires dans la Colonne A
            x = x + 1
        End If  '
    End If
    MyName = Dir    ' Extrait l'entrée suivante
    Loop