Déplacement fichiers et dossiers en vbs

bonjour à tous
je suis en train de tenter de finir un script en vbs pour déplacer des fichiers qui ont l'extension mdb, avec les dossiers qui les contienent, tou en gardant l'arborescence.

mon code donne à peu près cela pour le moment :

On Error Resume Next
liste = c:\liste.txt
strComputer = InputBox ("Adresse IP ")
strTarget = "Chemin UNC"
Const ForReading = 1

Set objFSO = CreateObject("Scripting.FileSystemObject")

If OFS.FileExists ("liste") Then
MsgBox "la liste de base de données existe"
Else
WScript.quit
End If

Set objFile = objFSO.OpenTextFile ("liste", ForReading)

Set objWMIService = GetObject ("winmgmts:\\" & strComputer & "\root\cimv2")

Do Until objFile.AtEndOfStream
strFolderName = objFile.ReadLine

Set objTextFile = objFSO.CreateTextFile ("C:\Scripts\Resultat_du_script.txt")

Getmdb (strfoldername)

Loop

Sub getmdb
Set colSubfolders = objWMIService.ExecQuery _
("Associators of {Win32_Directory.Name='" & strFolderName & "'} " _
& "Where AssocClass = Win32_Subdirectory " _
& "ResultRole = PartComponent")

Set colFiles = objWMIService.ExecQuery _
("ASSOCIATORS OF {Win32_Directory.Name='" & strFolderName & "'} Where " _
& "ResultClass = CIM_DataFile")

For Each objFile in colFiles
If objFile.Extension = "mdb" Then
objTextFile.WriteLine objFile.FileName & " Ok"
objFSO.MoveFile objFile.Name, strTarget
End If
Next

End Sub

et j'ai un petit soucis pour finir ce code car je n'arrive pas à balayer les sous dossiers qui doivent contenir les dits fichiers
un petit coup de main please