Friday, December 17, 2010

Get SubFolders and Files, Rename them and Copy at your desired path

Get the Files in subfolders and copy at desired location

ParentFolder="D:\Excel Results\" 'inputbox("Enter parentfolder path including "\")

SubFolder = "MemberShip" 'inputbox("Enter subfolder name")

Copy_Folder = inputbox("Enter the path to copy the files") 'without \ at end

Function Copy_Files(ParentFolder, SubFolder, Copy_Folder)

Dim fso,fs, drv,fldr,fil,fld, xl

set fso=createobject("Scripting.filesystemobject")


If (fso.folderexists(fldr)) Then

Set ParentFold = fso.GetFolder(fldr)

Set ChildFolds = ParentFold.subfolders

Set ChildFiles = ParentFold.Files

ChildFolds_Cnt = ChildFolds.count

Print "SubFolders Count is :"& ChildFolds_Cnt


For each subfolder in ChildFolds


Set reqFile = subfolder.files

print i &chr(32)& " SubFolder Name is :"&

For each get_File in reqFile

print "File Name before rename is: "&get_File.Name

Set xl = createobject("Excel.application")

xl.visible = true get_File.path

File_Rename = "Rename with"             'xl.range("B15").value


Set xl=nothing

wait 1

On Error Resume Next

' get_File.Rename File_Rename&".xls"


If Err.Number <>0 Then

print Err.Number &" :"& Err.Description

End If

print "Renamed file name is :"& get_File.Name

fso.copyfile get_File.path , Copy_Folder&"\", true



set fso=Nothing

Set ParentFold = Nothing

Set ChildFolds = Nothing

Set ChildFiles = Nothing

End If

End Function

Call Copy_Files(ParentFolder, SubFolder, Copy_Folder)

"A good threat is worth a thousand tests" - Boris Beizer

No comments: