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")

fldr=ParentFolder&SubFolder

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

i=0

For each subfolder in ChildFolds

i=i+1

Set reqFile = subfolder.files

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

For each get_File in reqFile

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

Set xl = createobject("Excel.application")

xl.visible = true

xl.workbooks.open get_File.path

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

xl.ActiveWorkbook.save

xl.quit

Set xl=nothing

wait 1

On Error Resume Next

' get_File.Rename File_Rename&".xls"

get_File.Name=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

Next

Next

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:

There was an error in this gadget