お試し下さい｡

Option Explicit

Dim objRecSet
Dim objFileSys
Dim objFolder
Dim objSubFolder
Dim objSubFolders
Dim strPath
Dim intCnt
Dim intNFiles
Dim strFileName
Dim strFNSorted

Const INT_N_FILES = 10 ' ｽｷｯﾌﾟするﾌｧｲﾙ数
Const STR_PATH_SRC = "C:\XXXXX" ' ｺﾋﾟｰ元 親ﾌｫﾙﾀﾞ
Const STR_PATH_DST = "C:\YYYYY" ' ｺﾋﾟｰ先 親ﾌｫﾙﾀﾞ

Const AD_VAR_CHAR = 200 ' adVarChar, ADO DataTypeEnum

Set objFileSys = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFileSys.GetFolder(STR_PATH_SRC)
Set objSubFolders = objFolder.SubFolders

For Each objSubFolder In objSubFolders
 intNFiles = objSubFolder.Files.Count
 If objSubFolder.Files.Count > INT_N_FILES Then
 strPath = STR_PATH_DST & "\" & objSubFolder.Name
 If Not objFileSys.FolderExists(strPath) Then
 objFileSys.CreateFolder(strPath)
 End If
 Set objRecSet = CreateObject("ADODB.Recordset")
 Call objRecSet.Fields.Append("FileName", AD_VAR_CHAR, 255)
 Call objRecSet.Open()
 For Each strFileName In objSubFolder.Files
 Call objRecSet.AddNew()
 objRecSet.Fields("FileName").Value = strFileName.Name
 Next
 Call objRecSet.Update()
 objRecSet.Sort = "FileName ASC"
 strFNSorted = objRecSet.GetRows()
 Call objRecSet.Close()
 Set objRecSet = Nothing
 For intCnt = INT_N_FILES To intNFiles - 1
 Call objFileSys.CopyFile(objSubFolder & "\" & strFNSorted(0, intCnt), strPath & "\" & strFNSorted(0, intCnt), True)
 Next
 End If
Next

MsgBox "処理を終了しました｡", vbOkOnly + vbInformation, "終了"