VBA Marco To Copy Excel Files From Sub-Directory To Another Directory [Archive] - Excel, Access, PowerPoint and Word VBA Macro Automation Help

View Full Version : VBA Marco To Copy Excel Files From Sub-Directory To Another Directory

Howardc

05-31-2013, 08:21 AM

I have a directory called pull containing several sub-directories for eg C:\pull\10tb , c:\pull\15tb, C:\pull\20tb etc. I would like a macro to copy all the Excel files (xls, xlsm etc) in these subdirectories and to copy these to C:\summary profits. If there are any existing workbooks in C:\summary profits these may be overwritten/replaced when copying the workbooks

I have also posted on the link below

Macro to copy files from one diretory into another (http://www.mrexcel.com/forum/excel-questions/705137-macro-copy-files-one-diretory-into-another.html)

https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgwplzlpYpmRqjGZem14AaABAg.9hrvbYRwXvg9ht4b7z00 X0 (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgwplzlpYpmRqjGZem14AaABAg.9hrvbYRwXvg9ht4b7z00 X0)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgyOGlCElBSbfPIzerF4AaABAg.9hrehNPPnBu9ht4us7Tt Pr (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgyOGlCElBSbfPIzerF4AaABAg.9hrehNPPnBu9ht4us7Tt Pr)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgwHjKXf3ELkU4u4j254AaABAg.9hr503K8PDg9ht5mfLcg pR (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgwHjKXf3ELkU4u4j254AaABAg.9hr503K8PDg9ht5mfLcg pR)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugw1-OyZiDDxCHM2Rmp4AaABAg.9hqzs_MlQu-9ht5xNvQueN (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugw1-OyZiDDxCHM2Rmp4AaABAg.9hqzs_MlQu-9ht5xNvQueN)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz0Uy2bCSCTb1W-0_14AaABAg (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz0Uy2bCSCTb1W-0_14AaABAg)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz0Uy2bCSCTb1W-0_14AaABAg.9htChVuaX9W9htG01cKBzX (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz0Uy2bCSCTb1W-0_14AaABAg.9htChVuaX9W9htG01cKBzX)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugw6UrV69zpeKvLOeOV4AaABAg.9ht16tzryC49htJ6TpIO XR (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugw6UrV69zpeKvLOeOV4AaABAg.9ht16tzryC49htJ6TpIO XR)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgwMKwGZpDjv7vi7pCx4AaABAg (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgwMKwGZpDjv7vi7pCx4AaABAg)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugw6UrV69zpeKvLOeOV4AaABAg.9ht16tzryC49htOKs4jh 3M (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugw6UrV69zpeKvLOeOV4AaABAg.9ht16tzryC49htOKs4jh 3M)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgxVW-am20rQ5GFuJ9F4AaABAg (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgxVW-am20rQ5GFuJ9F4AaABAg)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugygb0YiLOI7fG1zQSx4AaABAg (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugygb0YiLOI7fG1zQSx4AaABAg)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugygb0YiLOI7fG1zQSx4AaABAg.9htWqRrSIfP9i-fyT84gqd (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugygb0YiLOI7fG1zQSx4AaABAg.9htWqRrSIfP9i-fyT84gqd)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugygb0YiLOI7fG1zQSx4AaABAg.9htWqRrSIfP9i-kIDl-3C9 (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugygb0YiLOI7fG1zQSx4AaABAg.9htWqRrSIfP9i-kIDl-3C9)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz0Uy2bCSCTb1W-0_14AaABAg.9htChVuaX9W9i57J9GEOUB (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz0Uy2bCSCTb1W-0_14AaABAg.9htChVuaX9W9i57J9GEOUB)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz0Uy2bCSCTb1W-0_14AaABAg.9htChVuaX9W9i58MGeM8Lg (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz0Uy2bCSCTb1W-0_14AaABAg.9htChVuaX9W9i58MGeM8Lg)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz0Uy2bCSCTb1W-0_14AaABAg.9htChVuaX9W9i59prk5atY (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz0Uy2bCSCTb1W-0_14AaABAg.9htChVuaX9W9i59prk5atY)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgwaWs6XDXdQybNb8tZ4AaABAg.9i5yTldIQBn9i7NB1gjy Bk (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgwaWs6XDXdQybNb8tZ4AaABAg.9i5yTldIQBn9i7NB1gjy Bk)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgxV9eNHvztLfFBGsvZ4AaABAg.9i5jEuidRs99i7NUtNNy 1v (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgxV9eNHvztLfFBGsvZ4AaABAg.9i5jEuidRs99i7NUtNNy 1v)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugx2zSXUtmLBSDoNWph4AaABAg.9i3IA0y4fqp9i7NySrZa md (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugx2zSXUtmLBSDoNWph4AaABAg.9i3IA0y4fqp9i7NySrZa md)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9i7Qs8kxE qH (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9i7Qs8kxE qH)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9i7TqGQYq Tz (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9i7TqGQYq Tz)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAJSNws8 Zz (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAJSNws8 Zz)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAJvZ6km lx (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAJvZ6km lx)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAK0g1dU 7i (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAK0g1dU 7i)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAKCDqNm nF (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAKCDqNm nF)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAKHVSTG Hy (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAKHVSTG Hy)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAKSBKPc J6 (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAKSBKPc J6)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAKgL6lr cT (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAKgL6lr cT)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAKlts8h KZ (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAKlts8h KZ)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAKrX7UP P0 (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAKrX7UP P0)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAL5MSjW pA (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAL5MSjW pA)

LalitPandey87

05-31-2013, 09:26 AM

Give a try to this code and change source and destination path accordingly:

Option Explicit

Sub Copy_Files_To_New_Folder()
''This procedure will copy/move all files in a folder to another specified folder'''
''Can be easily modified

Dim objFSO As Object, objFolder As Object, PathExists As Boolean
Dim objFile As Object, strSourceFolder As String, strDestFolder As String
Dim x, Counter As Integer, Overwrite As String

Application.ScreenUpdating = False 'turn screenupdating off
Application.EnableEvents = False 'turn events off

'identify path names below:
strSourceFolder = "C:\MyFolder" 'Source path
strDestFolder = "C:\Backup" 'destination path, does not have to exist prior to execution

'below will verify that the specified destination path exists, or it will create it:
On Error Resume Next
x = GetAttr(strDestFolder) And 0
If Err = 0 Then 'if there is no error, continue below
PathExists = True 'if there is no error, set flag to TRUE
Overwrite = MsgBox("The folder may contain duplicate files," & vbNewLine & _
"Do you wish to overwrite existing files with same name?", vbYesNo, "Alert!")
'message to alert that you may overwrite files of the same name since folder exists
If Overwrite <> vbYes Then Exit Sub 'if the user clicks YES, then exit the routine..
Else: 'if path does NOT exist, do the next steps
PathExists = False 'set flag at false
If PathExists = False Then MkDir (strDestFolder) 'If path does not exist, make a new one
End If 'end the conditional testing

On Error GoTo ErrHandler
Set objFSO = CreateObject("Scripting.FileSystemObject") 'creates a new File System Object reference
Set objFolder = objFSO.GetFolder(strSourceFolder) 'get the folder
Counter = 0 'set the counter at zero for counting files copied

If Not objFolder.Files.Count > 0 Then GoTo NoFiles 'if no files exist in source folder "Go To" the NoFiles section

For Each objFile In objFolder.Files 'for every file in the folder...

If LCase(objFile.Type) Like LCase("Microsoft Office Excel*") Then
objFile.Copy strDestFolder & "\" & objFile.Name 'Copy file
Counter = Counter + 1 'increment a count of files copied
End If

Next objFile 'go to the next file

MsgBox "All " & Counter & " Files from " & vbCrLf & vbCrLf & strSourceFolder & vbNewLine & vbNewLine & _
" copied/moved to: " & vbCrLf & vbCrLf & strDestFolder, , "Completed Transfer/Copy!"

Set objFile = Nothing: Set objFSO = Nothing: Set objFolder = Nothing 'clear the objects

Exit Sub

NoFiles:
'Message to alert if Source folder has no files in it to copy
MsgBox "There Are no files or documents in : " & vbNewLine & vbNewLine & _
strSourceFolder & vbNewLine & vbNewLine & "Please verify the path!", , "Alert: No Files Found!"
Set objFile = Nothing: Set objFSO = Nothing: Set objFolder = Nothing 'clear the objects

Application.ScreenUpdating = True 'turn screenupdating back on
Application.EnableEvents = True 'turn events back on

Exit Sub 'exit sub here to avoid subsequent actions

ErrHandler:
'A general error message
MsgBox "Error: " & Err.Number & Err.Description & vbCrLf & vbCrLf & vbCrLf & _
"Please verify that all files in the folder are not currently open," & _
"and the source directory is available"

Err.Clear 'clear the error
Set objFile = Nothing: Set objFSO = Nothing: Set objFolder = Nothing 'clear the objects
Application.ScreenUpdating = True 'turn screenupdating back on
Application.EnableEvents = True 'turn events back on
End Sub

:cheers:

https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgwplzlpYpmRqjGZem14AaABAg.9hrvbYRwXvg9ht4b7z00 X0 (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgwplzlpYpmRqjGZem14AaABAg.9hrvbYRwXvg9ht4b7z00 X0)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgyOGlCElBSbfPIzerF4AaABAg.9hrehNPPnBu9ht4us7Tt Pr (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgyOGlCElBSbfPIzerF4AaABAg.9hrehNPPnBu9ht4us7Tt Pr)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgwHjKXf3ELkU4u4j254AaABAg.9hr503K8PDg9ht5mfLcg pR (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgwHjKXf3ELkU4u4j254AaABAg.9hr503K8PDg9ht5mfLcg pR)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugw1-OyZiDDxCHM2Rmp4AaABAg.9hqzs_MlQu-9ht5xNvQueN (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugw1-OyZiDDxCHM2Rmp4AaABAg.9hqzs_MlQu-9ht5xNvQueN)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz0Uy2bCSCTb1W-0_14AaABAg (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz0Uy2bCSCTb1W-0_14AaABAg)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz0Uy2bCSCTb1W-0_14AaABAg.9htChVuaX9W9htG01cKBzX (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz0Uy2bCSCTb1W-0_14AaABAg.9htChVuaX9W9htG01cKBzX)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugw6UrV69zpeKvLOeOV4AaABAg.9ht16tzryC49htJ6TpIO XR (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugw6UrV69zpeKvLOeOV4AaABAg.9ht16tzryC49htJ6TpIO XR)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgwMKwGZpDjv7vi7pCx4AaABAg (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgwMKwGZpDjv7vi7pCx4AaABAg)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugw6UrV69zpeKvLOeOV4AaABAg.9ht16tzryC49htOKs4jh 3M (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugw6UrV69zpeKvLOeOV4AaABAg.9ht16tzryC49htOKs4jh 3M)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgxVW-am20rQ5GFuJ9F4AaABAg (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgxVW-am20rQ5GFuJ9F4AaABAg)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugygb0YiLOI7fG1zQSx4AaABAg (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugygb0YiLOI7fG1zQSx4AaABAg)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugygb0YiLOI7fG1zQSx4AaABAg.9htWqRrSIfP9i-fyT84gqd (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugygb0YiLOI7fG1zQSx4AaABAg.9htWqRrSIfP9i-fyT84gqd)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugygb0YiLOI7fG1zQSx4AaABAg.9htWqRrSIfP9i-kIDl-3C9 (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugygb0YiLOI7fG1zQSx4AaABAg.9htWqRrSIfP9i-kIDl-3C9)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz0Uy2bCSCTb1W-0_14AaABAg.9htChVuaX9W9i57J9GEOUB (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz0Uy2bCSCTb1W-0_14AaABAg.9htChVuaX9W9i57J9GEOUB)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz0Uy2bCSCTb1W-0_14AaABAg.9htChVuaX9W9i58MGeM8Lg (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz0Uy2bCSCTb1W-0_14AaABAg.9htChVuaX9W9i58MGeM8Lg)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz0Uy2bCSCTb1W-0_14AaABAg.9htChVuaX9W9i59prk5atY (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz0Uy2bCSCTb1W-0_14AaABAg.9htChVuaX9W9i59prk5atY)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgwaWs6XDXdQybNb8tZ4AaABAg.9i5yTldIQBn9i7NB1gjy Bk (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgwaWs6XDXdQybNb8tZ4AaABAg.9i5yTldIQBn9i7NB1gjy Bk)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgxV9eNHvztLfFBGsvZ4AaABAg.9i5jEuidRs99i7NUtNNy 1v (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=UgxV9eNHvztLfFBGsvZ4AaABAg.9i5jEuidRs99i7NUtNNy 1v)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugx2zSXUtmLBSDoNWph4AaABAg.9i3IA0y4fqp9i7NySrZa md (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugx2zSXUtmLBSDoNWph4AaABAg.9i3IA0y4fqp9i7NySrZa md)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9i7Qs8kxE qH (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9i7Qs8kxE qH)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9i7TqGQYq Tz (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9i7TqGQYq Tz)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAJSNws8 Zz (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAJSNws8 Zz)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAJvZ6km lx (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAJvZ6km lx)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAK0g1dU 7i (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAK0g1dU 7i)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAKCDqNm nF (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAKCDqNm nF)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAKHVSTG Hy (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAKHVSTG Hy)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAKSBKPc J6 (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAKSBKPc J6)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAKgL6lr cT (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAKgL6lr cT)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAKlts8h KZ (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAKlts8h KZ)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAKrX7UP P0 (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAKrX7UP P0)
https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAL5MSjW pA (https://www.youtube.com/watch?v=LuAipOW8BNQ&lc=Ugz4oMZ09MKcExYlWf94AaABAg.9hwsCHaKX6A9iAL5MSjW pA)

Howardc

05-31-2013, 09:48 AM

Hi

Thanks for the help,much appreciated

The codes copied csv files from C\:Pull directory. What I need is to copy excel files ending in xls, xlsm etc from Pull sub-directories for eg C:\pull\10tb, C:\pull\15tb etc

It would be appreciated if you could amend your code to assist

LalitPandey87

05-31-2013, 01:44 PM

Here you go with changed code higlighted with red color:

Option Explicit

Sub Copy_Files_To_New_Folder()
''This procedure will copy/move all files in a folder to another specified folder'''
''Can be easily modified

Dim objFSO As Object, objFolder As Object, PathExists As Boolean
Dim objFile As Object, strSourceFolder As String, strDestFolder As String
Dim x, Counter As Integer, Overwrite As String

Application.ScreenUpdating = False 'turn screenupdating off
Application.EnableEvents = False 'turn events off

'identify path names below:
strSourceFolder = "C:\MyFolder" 'Source path
strDestFolder = "C:\Backup" 'destination path, does not have to exist prior to execution

'below will verify that the specified destination path exists, or it will create it:
On Error Resume Next
x = GetAttr(strDestFolder) And 0
If Err = 0 Then 'if there is no error, continue below
PathExists = True 'if there is no error, set flag to TRUE
Overwrite = MsgBox("The folder may contain duplicate files," & vbNewLine & _
"Do you wish to overwrite existing files with same name?", vbYesNo, "Alert!")
'message to alert that you may overwrite files of the same name since folder exists
If Overwrite <> vbYes Then Exit Sub 'if the user clicks YES, then exit the routine..
Else: 'if path does NOT exist, do the next steps
PathExists = False 'set flag at false
If PathExists = False Then MkDir (strDestFolder) 'If path does not exist, make a new one
End If 'end the conditional testing

On Error GoTo ErrHandler
Set objFSO = CreateObject("Scripting.FileSystemObject") 'creates a new File System Object reference
Set objFolder = objFSO.GetFolder(strSourceFolder) 'get the folder
Counter = 0 'set the counter at zero for counting files copied

If Not objFolder.Files.Count > 0 Then GoTo NoFiles 'if no files exist in source folder "Go To" the NoFiles section

For Each objFile In objFolder.Files 'for every file in the folder...

If LCase(objFSO.GetExtensionName(objFile.Path)) Like "xl*" Then
objFile.Copy strDestFolder & "\" & objFile.Name 'Copy file
Counter = Counter + 1 'increment a count of files copied
End If

Next objFile 'go to the next file

MsgBox "All " & Counter & " Files from " & vbCrLf & vbCrLf & strSourceFolder & vbNewLine & vbNewLine & _
" copied/moved to: " & vbCrLf & vbCrLf & strDestFolder, , "Completed Transfer/Copy!"

Set objFile = Nothing: Set objFSO = Nothing: Set objFolder = Nothing 'clear the objects

Exit Sub

NoFiles:
'Message to alert if Source folder has no files in it to copy
MsgBox "There Are no files or documents in : " & vbNewLine & vbNewLine & _
strSourceFolder & vbNewLine & vbNewLine & "Please verify the path!", , "Alert: No Files Found!"
Set objFile = Nothing: Set objFSO = Nothing: Set objFolder = Nothing 'clear the objects

Application.ScreenUpdating = True 'turn screenupdating back on
Application.EnableEvents = True 'turn events back on

Exit Sub 'exit sub here to avoid subsequent actions

ErrHandler:
'A general error message
MsgBox "Error: " & Err.Number & Err.Description & vbCrLf & vbCrLf & vbCrLf & _
"Please verify that all files in the folder are not currently open," & _
"and the source directory is available"

Err.Clear 'clear the error
Set objFile = Nothing: Set objFSO = Nothing: Set objFolder = Nothing 'clear the objects
Application.ScreenUpdating = True 'turn screenupdating back on
Application.EnableEvents = True 'turn events back on
End Sub

Excel Fox

05-31-2013, 03:10 PM

Try this....

Sub MoveFilesToAnotherFolder()

Dim objFSO As Object 'FileSystemObject
Dim objFile As Object 'File
Dim objFolder As Object 'Folder
Const strFolder As String = "C:\pull"
Const strNewFolder As String = "C:\summary profits"
Set objFSO = CreateObject("Scripting.FileSystemObject")
For Each objFolder In objFSO.GetFolder(strFolder & "\").SubFolders
If Right(objFolder.Name, 2) = "tb" Then
For Each objFile In objFolder.Files
If InStr(1, objFile.Type, "Excel", vbTextCompare) Then
Name objFile.Path As strNewFolder & "\" & objFile.Name
End If
Next objFile
End If
Next objFolder

End Sub

Howardc

05-31-2013, 08:21 PM

Thanks for the help. The subdirectory in pull for eg C:\pull\\10tb , C:\pull\15tb are not copied

It would be appreciated if you could amenmd the code to accomodate the sub-directories in C:\pull

Howardc

05-31-2013, 08:25 PM

Hi Excelfox

Thanks for the help. When activating the macro, run time error 58 appears "file already exists" and the following code is highlighted

Name objFile.Path As strNewFolder & "\" & objFile.Name

It would be appreciated if you could amend your code

snb

05-31-2013, 09:05 PM

@Howardc

You don't give the impression that you test the code, nor that you analyse or amend or improve the code or study the components it is being made off.
If you are only looking for a ready made solution I can only advice you to hire a professional software developer. I happen to know one of those. So if you are interested I can connect the two of you.

Excel Fox

05-31-2013, 10:00 PM

Howardc, as snb said, please have a look at the code and analyze what's the code trying to do. That way, you'll also be able to come up with some of your own code to counter any errors or make any modifications based on your requirement. In the above error you've mentioned for example, you already understood that the error is because the file already exists. So you could either decide to keep the original file, OR overwrite it.

One of the ways to manage this is to use an On Error statement that will ignore an error. So you could either use

Sub MoveFilesToAnotherFolder()

Dim objFSO As Object 'FileSystemObject
Dim objFile As Object 'File
Dim objFolder As Object 'Folder
Const strFolder As String = "C:\pull"
Const strNewFolder As String = "C:\summary profits"
Set objFSO = CreateObject("Scripting.FileSystemObject")
For Each objFolder In objFSO.GetFolder(strFolder & "\").SubFolders
If Right(objFolder.Name, 2) = "tb" Then
For Each objFile In objFolder.Files
If InStr(1, objFile.Type, "Excel", vbTextCompare) Then
On Error Resume Next
Kill strNewFolder & "\" & objFile.Name
Err.Clear:On Error GoTo 0
Name objFile.Path As strNewFolder & "\" & objFile.Name
End If
Next objFile
End If
Next objFolder

End Sub

to overwrite the file, OR

Sub MoveFilesToAnotherFolder()

Dim objFSO As Object 'FileSystemObject
Dim objFile As Object 'File
Dim objFolder As Object 'Folder
Const strFolder As String = "C:\pull"
Const strNewFolder As String = "C:\summary profits"
Set objFSO = CreateObject("Scripting.FileSystemObject")
For Each objFolder In objFSO.GetFolder(strFolder & "\").SubFolders
If Right(objFolder.Name, 2) = "tb" Then
For Each objFile In objFolder.Files
If InStr(1, objFile.Type, "Excel", vbTextCompare) Then
On Error Resume Next
Name objFile.Path As strNewFolder & "\" & objFile.Name
Err.Clear:On Error GoTo 0
End If
Next objFile
End If
Next objFolder

End Sub

to keep the original file

Howardc

05-31-2013, 11:31 PM

Hi Guys

Thanks for the advise. I was rather hectiic today and did not have time to analyse the code, but will in future do so as I want to improve my VBA knowledge