Create FOLDER in subfoldesr and move folders with specific names into FOLDER

Hi,

the below code creates a "2013" Folder in all the subfolder and move any "FILE having 2013 in it's name" to "2013" Folder, is it possible to move any "SUBFOLDER that has 2013 in it's name" to "2013" Folder? Current code moves only Files that have 2013 in their name but not subfolders that have 2013 in their name.

Sub AddSubfolder()
'Under tools, add reference to Microsoft Scripting Runtime
Dim FSO As Scripting.FileSystemObject
Dim RootFolder As Object
Dim SubFolder As Object
Dim myFolder As String
Dim myNewFolder As String
Dim mySubfolderPath As String
Dim myFile As String
Set FSO = CreateObject("Scripting.FileSystemObject")
myFolder = "D:\Users\703038355\Desktop\oFile\" 'Change to identify your main folder
Set RootFolder = FSO.GetFolder(myFolder)
For Each SubFolder In RootFolder.SubFolders
Debug.Print SubFolder.Path
mySubfolderPath = SubFolder.Path
myNewFolder = mySubfolderPath & "\2013"
If Not FSO.FolderExists(myNewFolder) Then
MkDir (myNewFolder)
myFile = Dir(mySubfolderPath & "\*2013*")
Do While myFile <> ""
FSO.MoveFile mySubfolderPath & "\" & myFile, myNewFolder & "\" & myFile

myFile = Dir
Loop

End If
Next SubFolder

End Sub
Thanks in advance.

Amar