<!--QuoteBegin--></div><table border='0' align='center' width='95%' cellpadding='3' cellspacing='1'><tr><td>
Цитата </td></tr><tr><td id='QUOTE'><!--QuoteEBegin--> вообще этот скрипт надо уже дополнить и теми делами, что там еще требовались (перенесение файлов в эти подпапки). Останется дописать всего-то пару строк.<!--QuoteEnd--></td></tr></table><div class='postcolor'><!--QuoteEEnd-->
пару строк не удалось
но для перемещения написали скрипт, иногда просто папки не нужно создавать.
так что если кому интересно:
Dim fso
Dim rf, sf, files, file
Set fso = CreateObject("Scripting.FileSystemObject")
Set rf = fso.GetFolder("c:\temp\")
For Each sf In rf.SubFolders
on error resume next
sfname = sf.path + "\"
dfname = sf.path + "\" + "History\"
fso.MoveFile sfname + "*.jpg", dfname
fso.MoveFile sfname + "*.met", dfname
fso.MoveFile sfname + "*.hdr", dfname
fso.MoveFile sfname + "*.ip3", dfname
Next
Set rf = Nothing
Set fso = Nothing
как обычно внутри все меняется на нужное