Copy complete folder to another folder

[mohanraj.610]

I need to move all the folders and it contents to a new folder. Folder names are given as in Source folder Column A and the Destination folder is B.

New folder needs to be created if destination doesn't exist. Someone help me out.

Source Folder	Dest
a	xx
a1	xx
b1	xx
c1	xx
a2	yy
a3	yy

[mdmackillop]

http://www.rondebruin.nl/win/s3/win026.htm

[Leith Ross]

Hello mohanraj.610,

This code will do what you want. It Starts with cell A2 on the Active Sheet. You can change this to any cell you want for your starting cell.

The macro does not overwrite the files in the destination automatically. It will ask you if you want to or not. Let me know if you want this changed to do that.

Sub CopyFolders()

    Dim Cell        As Range
    Dim DstFolder   As Variant
    Dim RngBeg      As Range
    Dim RngEnd      As Range
    Dim SrcFolder   As Variant
    Dim Wks         As Worksheet
    
        Set Wks = ActiveSheet
        
        Set RngBeg = Wks.Range("A2")
        Set RngEnd = Wks.Cells(Rows.Count, "A").End(xlUp)
        If RngEnd.Row < RngBeg.Row Then Exit Sub
        
        With CreateObject("Shell.Application")
            For Each Cell In Wks.Range(RngBeg, RngEnd)
                SrcFolder = Cell
                SrcFolder = IIf(Right(SrcFolder, 1) <> "\", SrcFolder & "\", SrcFolder)
                Set SrcFolder = .Namespace(SrcFolder)
                
                DstFolder = Cell.Offset(0, 1)
                DstFolder = IIf(Right(DstFolder, 1) <> "\", DstFolder & "\", DstFolder)
                If .Namespace(DstFolder) Is Nothing Then MkDir DstFolder
                Set DstFolder = .Namespace(DstFolder)
                DstFolder.CopyHere SrcFolder, 76
            Next Cell
        End With
        
End Sub

[mohanraj.610]

Hi mdmackillop and Leith,

Thanks for the response.

I have attached the layout for clear view.

I have list of folder that has to be copied with a different names and all the contents in folder needs to be completely copied/moved. New folder needs to be created and moved if folder doesn't exist.

[Leith Ross]

Hello mohanraj.610,

Here is the updated macro code.

Sub CopyFolders()

    Dim Cell        As Range
    Dim DstFolder   As Variant
    Dim DstPath     As Variant
    Dim RngBeg      As Range
    Dim RngEnd      As Range
    Dim SrcFolder   As Variant
    Dim SrcPath     As Variant
    Dim Wks         As Worksheet
    
        Set Wks = ActiveSheet
        
        SrcPath = Wks.Range("B3")
        SrcPath = IIf(Right(SrcPath, 1) <> "\", SrcPath & "\", SrcPath)
        
        DstPath = Wks.Range("D3")
        DstPath = IIf(Right(DstPath, 1) <> "\", DstPath & "\", DstPath)
        
        Set RngBeg = Wks.Range("B6")
        Set RngEnd = Wks.Cells(Rows.Count, RngBeg.Column).End(xlUp)
        If RngEnd.Row < RngBeg.Row Then Exit Sub
        
        With CreateObject("Shell.Application")
            For Each Cell In Wks.Range(RngBeg, RngEnd)
                SrcFolder = SrcPath & Cell
                Set SrcFolder = .Namespace(SrcFolder)
                
                DstFolder = DstPath & Cell.Offset(0, 2)
                If .Namespace(DstFolder) Is Nothing Then MkDir DstFolder
                Set DstFolder = .Namespace(DstFolder)
                DstFolder.CopyHere SrcFolder, 76
            Next Cell
        End With
        
End Sub

[snb]

Sub M_snb()
  CreateObject("scripting.filesystemobject").MoveFolder "G:\OF\__tst", "G:\__tst"
End Sub

[Paul_Hossler]

I need to move all the folders and it contents to a new folder. Folder names are given as in Source folder Column A and the Destination folder is B.

New folder needs to be created if destination doesn't exist. Someone help me out.

I'm confused -- do you want to COPY the folders or MOVE the folders?

[mohanraj.610]

Hi Leith,

Macro is working fine. Thank you!!!