Macro to Copy Folder and all its contents (including subfolders) to a new location based on a list

[willow1985]

I have been looking online but cannot find exactly what I am looking for and I hope someone can help me.

I am looking for a code that will copy a folder and all of its contents (including subfolders) to another folder/directory based on the below list.

Would anyone be able to assist me with this? I am not very good at these types of codes.

There will be at least 5000 directories with multiple files. It will be a large amount of data copied.

Thank you to anyone who can help!

Book1
	A	B	C	D	E	F
1	Original Directory	Folder (and contents) to Move	Original Directory with Folder	Destination Directory	Destination Folder	Destination Directory and Folder
2	\\171.200.7.15\data\QT\Group\NCR\NCR Records 1101-Current\	NCR 1431	\\171.200.7.15\data\QT\Group\NCR\NCR Records 1101-Current\NCR 1431	\\171.200.7.15\data\QT\Quality Log\Quality Records\	Q0001	\\171.200.7.15\data\QT\Quality Log\Quality Records\Q0001
3	\\171.200.7.15\data\QT\Group\NCR\NCR Records 1101-Current\	NCR 1432	\\171.200.7.15\data\QT\Group\NCR\NCR Records 1101-Current\NCR 1432	\\171.200.7.15\data\QT\Quality Log\Quality Records\	Q0002	\\171.200.7.15\data\QT\Quality Log\Quality Records\Q0002
4	\\171.200.7.15\data\QT\Group\NCR\NCR Records 1101-Current\	NCR 1433	\\171.200.7.15\data\QT\Group\NCR\NCR Records 1101-Current\NCR 1433	\\171.200.7.15\data\QT\Quality Log\Quality Records\	Q0003	\\171.200.7.15\data\QT\Quality Log\Quality Records\Q0003
5	\\171.200.7.15\data\QT\Group\NCR\NCR Records 1101-Current\	NCR 1434	\\171.200.7.15\data\QT\Group\NCR\NCR Records 1101-Current\NCR 1434	\\171.200.7.15\data\QT\Quality Log\Quality Records\	Q0004	\\171.200.7.15\data\QT\Quality Log\Quality Records\Q0004
6	\\171.200.7.15\data\QT\Group\NCR\NCR Records 1101-Current\	NCR 1435	\\171.200.7.15\data\QT\Group\NCR\NCR Records 1101-Current\NCR 1435	\\171.200.7.15\data\QT\Quality Log\Quality Records\	Q0005	\\171.200.7.15\data\QT\Quality Log\Quality Records\Q0005
7	\\171.200.7.15\data\QT\Group\NCR\NCR Records 1101-Current\	NCR 1436	\\171.200.7.15\data\QT\Group\NCR\NCR Records 1101-Current\NCR 1436	\\171.200.7.15\data\QT\Quality Log\Quality Records\	Q0006	\\171.200.7.15\data\QT\Quality Log\Quality Records\Q0006
8	\\171.200.7.15\data\QT\Group\CC\CC Records\	CC 1000	\\171.200.7.15\data\QT\Group\CC\CC Records\CC 1000	\\171.200.7.15\data\QT\Quality Log\Quality Records\	Q0007	\\171.200.7.15\data\QT\Quality Log\Quality Records\Q0007
9	\\171.200.7.15\data\QT\Group\CC\CC Records\	CC 1001	\\171.200.7.15\data\QT\Group\CC\CC Records\CC 1001	\\171.200.7.15\data\QT\Quality Log\Quality Records\	Q0008	\\171.200.7.15\data\QT\Quality Log\Quality Records\Q0008
10	\\171.200.7.15\data\QT\Group\CC\CC Records\	CC 1002	\\171.200.7.15\data\QT\Group\CC\CC Records\CC 1002	\\171.200.7.15\data\QT\Quality Log\Quality Records\	Q0009	\\171.200.7.15\data\QT\Quality Log\Quality Records\Q0009
11	\\171.200.7.15\data\QT\Group\CC\CC Records\	CC 1003	\\171.200.7.15\data\QT\Group\CC\CC Records\CC 1003	\\171.200.7.15\data\QT\Quality Log\Quality Records\	Q0010	\\171.200.7.15\data\QT\Quality Log\Quality Records\Q0010
12	\\171.200.7.15\data\QT\Group\CAPA\CAPA Records\	CAPA 900	\\171.200.7.15\data\QT\Group\CAPA\CAPA Records\CAPA 900	\\171.200.7.15\data\QT\Quality Log\Quality Records\	Q0011	\\171.200.7.15\data\QT\Quality Log\Quality Records\Q0011
13	\\171.200.7.15\data\QT\Group\CAPA\CAPA Records\	CAPA 901	\\171.200.7.15\data\QT\Group\CAPA\CAPA Records\CAPA 901	\\171.200.7.15\data\QT\Quality Log\Quality Records\	Q0012	\\171.200.7.15\data\QT\Quality Log\Quality Records\Q0012
14	\\171.200.7.15\data\QT\Group\CAPA\CAPA Records\	CAPA 902	\\171.200.7.15\data\QT\Group\CAPA\CAPA Records\CAPA 902	\\171.200.7.15\data\QT\Quality Log\Quality Records\	Q0013	\\171.200.7.15\data\QT\Quality Log\Quality Records\Q0013
15	\\171.200.7.15\data\QT\Group\CAPA\CAPA Records\	CAPA 903	\\171.200.7.15\data\QT\Group\CAPA\CAPA Records\CAPA 903	\\171.200.7.15\data\QT\Quality Log\Quality Records\	Q0014	\\171.200.7.15\data\QT\Quality Log\Quality Records\Q0014
16	\\171.200.7.15\data\QT\Group\CAPA\CAPA Records\	CAPA 904	\\171.200.7.15\data\QT\Group\CAPA\CAPA Records\CAPA 904	\\171.200.7.15\data\QT\Quality Log\Quality Records\	Q0015	\\171.200.7.15\data\QT\Quality Log\Quality Records\Q0015
Sheet1

Cell Formulas
Range	Formula
C2:C16,F2:F16	C2	=A2&B2

 

[willow1985]

The below code works but I still would like to transfer the main folder as well as the contents (example NCR 1431 folder inside Q0001 folder.

Any assistance modifying this code would be greatly appreciated.

Sub Transfer_Files()
    Dim SourcePath As String, DestinationPath As String
    Dim fso As Object
    Dim LastRow As Long, i As Long
  
    Set fso = CreateObject("Scripting.FileSystemObject")
    
    LastRow = Cells(Rows.Count, "C").End(xlUp).Row

    
    For i = 1 To LastRow
        SourcePath = Cells(i, "C").Value
        DestinationPath = Cells(i, "F").Value
      
        If SourcePath <> "" And DestinationPath <> "" Then
          
            fso.CopyFolder SourcePath, DestinationPath
        End If
    Next i
  
    Set fso = Nothing
End Sub

 

[Sequoyah]

Hi, since in this case the first row contains the header, the loop must start from the second, try

For i = 2 To LastRow

 

[HighAndWilder]

The below code works but I still would like to transfer the main folder as well as the contents (example NCR 1431 folder inside Q0001 folder.

Any assistance modifying this code would be greatly appreciated.

Sub Transfer_Files()
    Dim SourcePath As String, DestinationPath As String
    Dim fso As Object
    Dim LastRow As Long, i As Long
 
    Set fso = CreateObject("Scripting.FileSystemObject")
   
    LastRow = Cells(Rows.Count, "C").End(xlUp).Row

   
    For i = 1 To LastRow
        SourcePath = Cells(i, "C").Value
        DestinationPath = Cells(i, "F").Value
     
        If SourcePath <> "" And DestinationPath <> "" Then
         
            fso.CopyFolder SourcePath, DestinationPath
        End If
    Next i
 
    Set fso = Nothing
End Sub

Give this a go.

It involves setting up the destination folder structure before the files and folders are copied.

I'd like to think that there is an easier way though.

Public Sub subCopyFoldersAndFiles()
Dim fso As Object
Dim rngFolders As Range
Dim arr()
Dim i As Integer

On Error GoTo Err_Handler

  ActiveWorkbook.Save
  
  Set fso = CreateObject("Scripting.FileSystemObject")
  
  Set rngFolders = Worksheets("FoldersMine").UsedRange

  arr = rngFolders
  
  For i = 2 To UBound(arr)
      
    ' Stage 1 : Create the new destination folder, name taken from column E.
    If Not fso.FolderExists(arr(i, 4) & "\" & arr(i, 5)) Then
      fso.CreateFolder (arr(i, 4) & "\" & arr(i, 5))
    End If
    
    ' Stage 2 : Create a sub-folder in the folder created in Stage 1 using the name of the
    ' source folder (Column B).
    If Not fso.FolderExists(arr(i, 6) & "\" & arr(i, 2)) Then
      fso.CreateFolder (arr(i, 6) & "\" & arr(i, 2))
    End If
   
    ' Stage 3 : Copy folders and files from the source folder to the folder created in Stage 2.
    fso.CopyFolder arr(i, 3), arr(i, 6) & "\" & arr(i, 2)

  Next i

  Set fso = Nothing
  
  MsgBox "Folders and files copied.", vbOKOnly, "Confirmation"
    
Exit_Handler:

  Exit Sub

Err_Handler:

  MsgBox "An error has occured using the data on row " & i & "." & vbCrLf & _
    Err.Number & " " & Err.Description, vbOKOnly, "Warning!"
  
  Resume Exit_Handler
    
End Sub

 

[DanteAmor]

Just add the blue part:

Sub Transfer_Files()
    Dim SourcePath As String, DestinationPath As String
    Dim fso As Object
    Dim LastRow As Long, i As Long
 
    Set fso = CreateObject("Scripting.FileSystemObject")
   
    For i = 2 To Cells(Rows.Count, "C").End(xlUp).Row
      SourcePath = Cells(i, "C").Value
      DestinationPath = Cells(i, "F").Value & "\" & Cells(i, "B").Value
     
      If SourcePath <> "" And DestinationPath <> "" Then
        If Not fso.FolderExists(DestinationPath) Then fso.CreateFolder DestinationPath
        fso.copyfolder SourcePath, DestinationPath
      End If
    Next i
 
    Set fso = Nothing
End Sub

 

[Tupacandres]

I'm not very expert in VBA (i only try to learn), but i try with the code of "DanteAmor" and don´t work for my, but modify his code and i think that is working now.

Sub Transfer_Files()
    Dim SourcePath As String, DestinationPath As String, DestinationPath2 As String
    Dim fso As Object
    Dim LastRow As Long, i As Long
 
    Set fso = CreateObject("Scripting.FileSystemObject")
   
    For i = 2 To Cells(Rows.Count, "C").End(xlUp).Row
      SourcePath = Cells(i, "C").Value
      DestinationPath = Cells(i, "F").Value
      DestinationPath2 = Cells(i, "F").Value & "\" & Cells(i, "B").Value
     
      If SourcePath <> "" And DestinationPath <> "" Then
        If Not fso.folderexists(DestinationPath) Then fso.Createfolder DestinationPath
            If Not fso.folderexists(DestinationPath2) Then fso.Createfolder DestinationPath2
            fso.CopyFolder SourcePath, DestinationPath2
      End If
    Next i
 
    Set fso = Nothing
End Sub

PD: Excuse my english, i'm from latin america.

 

[Tupacandres]

I'm not very expert in VBA (i only try to learn), but i try with the code of "DanteAmor" and don´t work for my, but modify his code and i think that is working now.

Sub Transfer_Files()
    Dim SourcePath As String, DestinationPath As String, DestinationPath2 As String
    Dim fso As Object
    Dim LastRow As Long, i As Long
 
    Set fso = CreateObject("Scripting.FileSystemObject")
  
    For i = 2 To Cells(Rows.Count, "C").End(xlUp).Row
      SourcePath = Cells(i, "C").Value
      DestinationPath = Cells(i, "F").Value
      DestinationPath2 = Cells(i, "F").Value & "\" & Cells(i, "B").Value
    
      If SourcePath <> "" And DestinationPath <> "" Then
        If Not fso.folderexists(DestinationPath) Then fso.Createfolder DestinationPath
            If Not fso.folderexists(DestinationPath2) Then fso.Createfolder DestinationPath2
            fso.CopyFolder SourcePath, DestinationPath2
      End If
    Next i
 
    Set fso = Nothing
End Sub

PD: Excuse my english, i'm from latin america.

Only add two lines and add a variable.