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

[tarvel]

Bonjour,
J'utilise cette macro pour lister les répertoires d'un Dossier sur une feuille.

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

Dans MonDossier il existe des répertoires
Archives20_09_2006,Archives21_09_2006,..etc...
J'aimerais en fait que lorsque Archives30_09_2006...(Archives fin de mois)
existe..que l'ensemble des répertoires Archives du mois soit déplacer vers
un répertoire à créer par exemple C:\MonDossier\ArchivesSeptembre.
Merci de votre aide!