Macro to copy files from one diretory into another

H

howard

Well-known Member
Joined
Jun 26, 2006
Messages
6,585
Office Version
  1. 2021
Platform
  1. Windows
I would like a macro to copy all .xls, xlsm workbooks from Directory Pull including sub-directories of Pull to directory "Summary profit Reports"

Your assistance in this regard is most appreciated
 

Excel Facts

Repeat Last Command
Pressing F4 adds dollar signs when editing a formula. When not editing, F4 repeats last command.
Sort by date Sort by votes
Hi Ron

Thanks for the link. I will try this later and let you know.I have a directory C:\pull with several sub-directories for eg C:\pull\10 , C:\pull\15, C:\pull\20 etc all containing .xls or xlsm extentions. Will this work with the code below for the sub-directories?


Sub Copy_Certain_Files_In_Folder()
'This example copy all Excel files from FromPath to ToPath.
'Note: If the files in ToPath already exist it will overwrite
'existing files in this folder
Dim FSO As Object
Dim FromPath As String
Dim ToPath As String
Dim FileExt As String

FromPath = "C:\pull" '<< Change
ToPath = "C:\summary profits" '<< Change

FileExt = "*.xl*" '<< Change
'You can use *.* for all files or *.doc for Word files

If Right(FromPath, 1) <> "\" Then
FromPath = FromPath & "\"
End If

Set FSO = CreateObject("scripting.filesystemobject")

If FSO.FolderExists(FromPath) = False Then
MsgBox FromPath & " doesn't exist"
Exit Sub
End If

If FSO.FolderExists(ToPath) = False Then
MsgBox ToPath & " doesn't exist"
Exit Sub
End If

FSO.CopyFile Source:=FromPath & FileExt, Destination:=ToPath
MsgBox "You can find the files from " & FromPath & " in " & ToPath

End Sub
 
Upvote 0
Hi Ron

I have used the fiollowing code as I have several sub-directories under direcvtory C:\pull for eg C:\pull\10tb, C:\pull\30tb etc

How can I show all the sub-directories to extract in your code as above?


ub Copy_Certain_Files_In_Folder()
'This example copy all Excel files from FromPath to ToPath.
'Note: If the files in ToPath already exist it will overwrite
'existing files in this folder
Dim FSO As Object
Dim FromPath As String
Dim ToPath As String
Dim FileExt As String

FromPath = "C:\pull\30tb" '<< Change
ToPath = "C:\summary profit Reports" '<< Change
FromPath = "C:\pull\10tb" '<< Change
ToPath = "C:\summary profit Reports" '<< Change


FileExt = "*.xl*" '<< Change
'You can use *.* for all files or *.doc for Word files

If Right(FromPath, 1) <> "\" Then
FromPath = FromPath & "\"
End If

Set FSO = CreateObject("scripting.filesystemobject")

If FSO.FolderExists(FromPath) = False Then
MsgBox FromPath & " doesn't exist"
Exit Sub
End If

If FSO.FolderExists(ToPath) = False Then
MsgBox ToPath & " doesn't exist"
Exit Sub
End If

FSO.CopyFile Source:=FromPath & FileExt, Destination:=ToPath
MsgBox "You can find the files from " & FromPath & " in " & ToPath

End Sub
 
Upvote 0
Why not copy the complete folder


Sub Copy_Folder()
'This example copy all files and subfolders from FromPath to ToPath.
'Note: If ToPath already exist it will overwrite existing files in this folder
'if ToPath not exist it will be made for you.
Dim FSO As Object
Dim FromPath As String
Dim ToPath As String

FromPath = "C:\Users\Ron\Data" '<< Change
ToPath = "C:\Users\Ron\Test" '<< Change

'If you want to create a backup of your folder every time you run this macro
'you can create a unique folder with a Date/Time stamp.
'ToPath = "C:\Users\Ron\" & Format(Now, "yyyy-mm-dd h-mm-ss")

If Right(FromPath, 1) = "\" Then
FromPath = Left(FromPath, Len(FromPath) - 1)
End If

If Right(ToPath, 1) = "\" Then
ToPath = Left(ToPath, Len(ToPath) - 1)
End If

Set FSO = CreateObject("scripting.filesystemobject")

If FSO.FolderExists(FromPath) = False Then
MsgBox FromPath & " doesn't exist"
Exit Sub
End If

FSO.CopyFolder Source:=FromPath, Destination:=ToPath
MsgBox "You can find the files and subfolders from " & FromPath & " in " & ToPath

End Sub
 
Upvote 0
Hi Ron

Thanks for the reply. I only want to extract excel files from the sub-folders within the Pull directory

It would be appreciated if you could assist

Regards

Howard
 
Upvote 0
Hi Ron

Thanks for the reply. I only want to extract excel files from the sub-folders within the Pull directory

It would be appreciated if you could assist

Regards

Howard
 
Upvote 0
Hello.

Take care to delete all files in 'ToPath' before execute again. I have no errorhandling included as this is my basis template for tasks like this. I have an log-function included which write FileNamePath and 'CopyDone' in first sheet starting in second row.

Classmodule (clsFileSearch):
Code: 
Option Explicit
Private Declare Function FindFirstFile Lib "kernel32.dll" Alias "FindFirstFileA" ( _
    ByVal lpFileName As String, _
    ByRef lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function FindNextFile Lib "kernel32.dll" Alias "FindNextFileA" ( _
    ByVal hFindFile As Long, _
    ByRef lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function FindClose Lib "kernel32.dll" ( _
    ByVal hFindFile As Long) As Long
Private Declare Function FileTimeToLocalFileTime Lib "kernel32.dll" ( _
    ByRef lpFileTime As FILETIME, _
    ByRef lpLocalFileTime As FILETIME) As Long
Private Declare Function FileTimeToSystemTime Lib "kernel32.dll" ( _
    ByRef lpFileTime As FILETIME, _
    ByRef lpSystemTime As SYSTEMTIME) As Long
Private Enum FILE_ATTRIBUTE
    FILE_ATTRIBUTE_READONLY = &H1
    FILE_ATTRIBUTE_HIDDEN = &H2
    FILE_ATTRIBUTE_SYSTEM = &H4
    FILE_ATTRIBUTE_DIRECTORY = &H10
    FILE_ATTRIBUTE_ARCHIVE = &H20
    FILE_ATTRIBUTE_NORMAL = &H80
    FILE_ATTRIBUTE_TEMPORARY = &H100
End Enum
Private Const MAX_PATH = 260&
Private Const INVALID_HANDLE_VALUE = -1&
Private Type FILETIME
    dwLowDateTime As Long
    dwHighDateTime As Long
End Type
Private Type SYSTEMTIME
    wYear As Integer
    wMonth As Integer
    wDayOfWeek As Integer
    wDay As Integer
    wHour As Integer
    wMinute As Integer
    wSecond As Integer
    wMilliseconds As Integer
End Type
Private Type WIN32_FIND_DATA
    dwFileAttributes As Long
    ftCreationTime As FILETIME
    ftLastAccessTime As FILETIME
    ftLastWriteTime As FILETIME
    nFileSizeHigh As Long
    nFileSizeLow As Long
    dwReserved0 As Long
    dwReserved1 As Long
    cFileName As String * MAX_PATH
    cAlternate As String * 14
End Type
Private mlngFileCount As Long
Private mudtFiles() As FILEINFO
Private mstrFolderPath As String
Private mstrExtension As String
Private mstrSearchLike As String
Private mblnSubFolders As Boolean
Private mblnCaseSenstiv As Boolean
Friend Property Get Files(lngIndex As Long) As FILEINFO
    Files = mudtFiles(lngIndex)
End Property
Friend Property Get FileCount() As Long
    FileCount = mlngFileCount
End Property
Friend Property Let FolderPath(strFolderPath As String)
    mstrFolderPath = strFolderPath
End Property
Friend Property Let Extension(strExtension As String)
    mstrExtension = strExtension
End Property
Friend Property Let SearchLike(strSearchLike As String)
    mstrSearchLike = strSearchLike
End Property
Friend Property Let SubFolders(blnSubFolders As Boolean)
    mblnSubFolders = blnSubFolders
End Property
Friend Property Let CaseSenstiv(blnCaseSenstiv As Boolean)
    mblnCaseSenstiv = blnCaseSenstiv
End Property
Friend Function Execute(Optional enmSortBy As SORT_BY = Sort_by_None, _
    Optional enmSortOrder As SORT_ORDER = Sort_Order_Ascending) As Long
    Call FindFiles(mstrFolderPath)
    If mlngFileCount > 1 And enmSortBy <> Sort_by_None Then _
        Call prcSort(1, mlngFileCount, enmSortBy, enmSortOrder)
    Execute = mlngFileCount
End Function
Private Sub FindFiles(ByVal strFolderPath As String)
    Dim WFD As WIN32_FIND_DATA, lngSearch As Long, strDirName As String
    On Error GoTo ErrorHandling
    If Right$(strFolderPath, 1) <> "\" Then strFolderPath = strFolderPath & "\"
    lngSearch = FindFirstFile(strFolderPath & "*.*", WFD)
    If lngSearch <> INVALID_HANDLE_VALUE Then
        Call GetFilesInFolder(strFolderPath)
        If mblnSubFolders Then
            Do
                If (WFD.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY) Then
                    strDirName = Left$(WFD.cFileName, InStr(WFD.cFileName, Chr$(0)) - 1)
                    If (strDirName <> ".") And (strDirName <> "..") Then _
                        Call FindFiles(strFolderPath & strDirName)
                End If
            Loop While FindNextFile(lngSearch, WFD)
        End If
        FindClose lngSearch
    End If
    Exit Sub
ErrorHandling:
    MsgBox "Fehler " & CStr(Err.Number) & vbLf & vbLf & _
        Err.Description, vbCritical, "Fehler"
End Sub
Private Sub GetFilesInFolder(ByVal strFolderPath As String)
    Dim WFD As WIN32_FIND_DATA, lngSearch As Long, strFilename As String
    Dim udtFiletime As FILETIME, udtSystemtime As SYSTEMTIME
    On Error GoTo ErrorHandling
    If Right$(strFolderPath, 1) <> "\" Then strFolderPath = strFolderPath & "\"
    lngSearch = FindFirstFile(strFolderPath & mstrExtension, WFD)
    If lngSearch <> INVALID_HANDLE_VALUE Then
        Do
            If (WFD.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY) <> FILE_ATTRIBUTE_DIRECTORY Then
                strFilename = Left$(WFD.cFileName, InStr(WFD.cFileName, Chr$(0)) - 1)
                If IIf(mblnCaseSenstiv, strFilename, LCase$(strFilename)) Like _
                    IIf(mblnCaseSenstiv, mstrSearchLike, LCase$(mstrSearchLike)) Then
                    mlngFileCount = mlngFileCount + 1
                    ReDim Preserve mudtFiles(1 To mlngFileCount)
                    With mudtFiles(mlngFileCount)
                        .strPath = strFolderPath & strFilename
                        .strFilename = strFilename
                        .lngSize = WFD.nFileSizeLow
                        FileTimeToLocalFileTime WFD.ftCreationTime, udtFiletime
                        FileTimeToSystemTime udtFiletime, udtSystemtime
                        .dmtDateCreate = CDate(DateSerial(udtSystemtime.wYear, udtSystemtime.wMonth, udtSystemtime.wDay) + _
                            TimeSerial(udtSystemtime.wHour, udtSystemtime.wMinute, udtSystemtime.wSecond))
                        FileTimeToLocalFileTime WFD.ftLastAccessTime, udtFiletime
                        FileTimeToSystemTime udtFiletime, udtSystemtime
                        .dmtLastAccess = CDate(DateSerial(udtSystemtime.wYear, udtSystemtime.wMonth, udtSystemtime.wDay) + _
                            TimeSerial(udtSystemtime.wHour, udtSystemtime.wMinute, udtSystemtime.wSecond))
                        FileTimeToLocalFileTime WFD.ftLastWriteTime, udtFiletime
                        FileTimeToSystemTime udtFiletime, udtSystemtime
                        .dmtLastModify = CDate(DateSerial(udtSystemtime.wYear, udtSystemtime.wMonth, udtSystemtime.wDay) + _
                            TimeSerial(udtSystemtime.wHour, udtSystemtime.wMinute, udtSystemtime.wSecond))
                    End With
                End If
            End If
        Loop While FindNextFile(lngSearch, WFD)
        FindClose lngSearch
    End If
    Exit Sub
ErrorHandling:
    MsgBox "Fehler " & CStr(Err.Number) & vbLf & vbLf & _
        Err.Description, vbCritical, "Fehler"
End Sub
Private Sub prcSort(lngLBorder As Long, lngUBorder As Long, enmSortBy As SORT_BY, enmSortOrder As SORT_ORDER)
    Dim lngIndex1 As Long, lngIndex2 As Long
    Dim udtBuffer As FILEINFO, vntTemp As Variant
    
    lngIndex1 = lngLBorder
    lngIndex2 = lngUBorder
    Select Case enmSortBy
      Case Sort_by_Name: vntTemp = mudtFiles((lngLBorder + lngUBorder) \ 2).strFilename
      Case Sort_by_Path: vntTemp = mudtFiles((lngLBorder + lngUBorder) \ 2).strPath
      Case Sort_by_Size: vntTemp = mudtFiles((lngLBorder + lngUBorder) \ 2).lngSize
      Case Sort_by_Last_Access: vntTemp = mudtFiles((lngLBorder + lngUBorder) \ 2).dmtLastAccess
      Case Sort_by_Last_Modyfy: vntTemp = mudtFiles((lngLBorder + lngUBorder) \ 2).dmtLastModify
      Case Sort_by_Date_Create: vntTemp = mudtFiles((lngLBorder + lngUBorder) \ 2).dmtDateCreate
    End Select
    Do
        Select Case enmSortBy
          Case Sort_by_Name
            If enmSortOrder = Sort_Order_Ascending Then
                Do While mudtFiles(lngIndex1).strFilename < vntTemp
                    lngIndex1 = lngIndex1 + 1
                Loop
                Do While vntTemp < mudtFiles(lngIndex2).strFilename
                    lngIndex2 = lngIndex2 - 1
                Loop
              Else
                Do While mudtFiles(lngIndex1).strFilename > vntTemp
                    lngIndex1 = lngIndex1 + 1
                Loop
                Do While vntTemp > mudtFiles(lngIndex2).strFilename
                    lngIndex2 = lngIndex2 - 1
                Loop
            End If
          Case Sort_by_Path
            If enmSortOrder = Sort_Order_Ascending Then
                Do While mudtFiles(lngIndex1).strPath < vntTemp
                    lngIndex1 = lngIndex1 + 1
                Loop
                Do While vntTemp < mudtFiles(lngIndex2).strPath
                    lngIndex2 = lngIndex2 - 1
                Loop
              Else
                Do While mudtFiles(lngIndex1).strPath > vntTemp
                    lngIndex1 = lngIndex1 + 1
                Loop
                Do While vntTemp > mudtFiles(lngIndex2).strPath
                    lngIndex2 = lngIndex2 - 1
                Loop
            End If
          Case Sort_by_Size
            If enmSortOrder = Sort_Order_Ascending Then
                Do While mudtFiles(lngIndex1).lngSize < vntTemp
                    lngIndex1 = lngIndex1 + 1
                Loop
                Do While vntTemp < mudtFiles(lngIndex2).lngSize
                    lngIndex2 = lngIndex2 - 1
                Loop
              Else
                Do While mudtFiles(lngIndex1).lngSize > vntTemp
                    lngIndex1 = lngIndex1 + 1
                Loop
                Do While vntTemp > mudtFiles(lngIndex2).lngSize
                    lngIndex2 = lngIndex2 - 1
                Loop
            End If
          Case Sort_by_Last_Access
            If enmSortOrder = Sort_Order_Ascending Then
                Do While mudtFiles(lngIndex1).dmtLastAccess < vntTemp
                    lngIndex1 = lngIndex1 + 1
                Loop
                Do While vntTemp < mudtFiles(lngIndex2).dmtLastAccess
                    lngIndex2 = lngIndex2 - 1
                Loop
              Else
                Do While mudtFiles(lngIndex1).dmtLastAccess > vntTemp
                    lngIndex1 = lngIndex1 + 1
                Loop
                Do While vntTemp > mudtFiles(lngIndex2).dmtLastAccess
                    lngIndex2 = lngIndex2 - 1
                Loop
            End If
          Case Sort_by_Last_Modyfy
            If enmSortOrder = Sort_Order_Ascending Then
                Do While mudtFiles(lngIndex1).dmtLastModify < vntTemp
                    lngIndex1 = lngIndex1 + 1
                Loop
                Do While vntTemp < mudtFiles(lngIndex2).dmtLastModify
                    lngIndex2 = lngIndex2 - 1
                Loop
              Else
                Do While mudtFiles(lngIndex1).dmtLastModify > vntTemp
                    lngIndex1 = lngIndex1 + 1
                Loop
                Do While vntTemp > mudtFiles(lngIndex2).dmtLastModify
                    lngIndex2 = lngIndex2 - 1
                Loop
            End If
          Case Sort_by_Date_Create
            If enmSortOrder = Sort_Order_Ascending Then
                Do While mudtFiles(lngIndex1).dmtDateCreate < vntTemp
                    lngIndex1 = lngIndex1 + 1
                Loop
                Do While vntTemp < mudtFiles(lngIndex2).dmtDateCreate
                    lngIndex2 = lngIndex2 - 1
                Loop
              Else
                Do While mudtFiles(lngIndex1).dmtDateCreate > vntTemp
                    lngIndex1 = lngIndex1 + 1
                Loop
                Do While vntTemp > mudtFiles(lngIndex2).dmtDateCreate
                    lngIndex2 = lngIndex2 - 1
                Loop
            End If
        End Select
        If lngIndex1 <= lngIndex2 Then
            udtBuffer = mudtFiles(lngIndex1)
            mudtFiles(lngIndex1) = mudtFiles(lngIndex2)
            mudtFiles(lngIndex2) = udtBuffer
            lngIndex1 = lngIndex1 + 1
            lngIndex2 = lngIndex2 - 1
        End If
    Loop Until lngIndex1 > lngIndex2
    If lngLBorder < lngIndex2 Then Call prcSort(lngLBorder, lngIndex2, enmSortBy, enmSortOrder)
    If lngIndex1 < lngUBorder Then Call prcSort(lngIndex1, lngUBorder, enmSortBy, enmSortOrder)
End Sub

Module:

Code: 
Option Explicit
Public Enum SORT_BY
    Sort_by_None
    Sort_by_Name
    Sort_by_Path
    Sort_by_Size
    Sort_by_Last_Access
    Sort_by_Last_Modyfy
    Sort_by_Date_Create
End Enum
Public Enum SORT_ORDER
    Sort_Order_Ascending
    Sort_Order_Descending
End Enum
Public Type FILEINFO
    strFilename As String
    strPath As String
    lngSize As Long
    dmtLastAccess As Date
    dmtLastModify As Date
    dmtDateCreate As Date
End Type
Public Sub GetFilePath_All()
    Dim objFileSearch As clsFileSearch
    Dim lngIndex As Long
    Dim a&
    Dim ToPath As String
    Dim FromPath As String
 
    FromPath = "C:\pull\" '<< Change
    ToPath = "C:\summary profits\" '<< Change
    
'**************************************************************************
'* get all excel files FromPath                                           *
'**************************************************************************
        
        a = 2
        Set objFileSearch = New clsFileSearch
        With objFileSearch
            .CaseSenstiv = True
            .Extension = "*.xls*"
            .FolderPath = FromPath
            .SearchLike = "*"
            .SubFolders = True
            If .Execute(Sort_by_Size, Sort_Order_Descending) > 0 Then
                For lngIndex = 1 To .FileCount
                    With .Files(lngIndex)
                        ThisWorkbook.Sheets(1).Cells(a, 1).Value = .strPath ', .lngSize
                        FileCopy .strPath, ToPath & .strFilename
                        ThisWorkbook.Sheets(1).Cells(a, 2).Value = "CopyDone"
                        a = a + 1
                    End With
                Next
            Else
                ThisWorkbook.Sheets(1).Cells((lngIndex + 2), 1).Value = "Nothing found"
            End If
        End With
        Set objFileSearch = Nothing
End Sub
 
Upvote 0
Thanks for the help. Will test later and advise
 
Upvote 0
Hello,

Thanks for the help. Have run the macro and the following code is highlighted
Public Sub GetFilePath_All()

Dim objFileSearch As clsFileSearch

and compile error appears "User-defined type not defined"

It would be appreciated if you would test & advise

Regards

Howard
 
Upvote 0
You must log in or register to reply here.

Similar threads

G
  • Question
Modify Single Email in Outlook Drafts subfolder
Replies
1
Views
306
g_speran
G
B
  • Question
Copy and paste from one worksheet into a new workbook and save to a particular directory
Replies
3
Views
358
Joe4
Joe4
C
  • Solved
Macro works for one file, does not work for all files in the directory
2
Replies
13
Views
1K
Alex Blakenburg
A
H
  • Question
selecting a folder and copying all files into another folder
2 3
Replies
20
Views
366
Holley
H
O
  • Solved
MS Excel VBA Macro to Open a MS Word File, Save the File and then Close the File
Replies
3
Views
572
OilEconomist
O

Forum statistics

Threads
1,221,537
Messages
6,160,405
Members
451,644
Latest member
hglymph

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top